diff --git a/Laborantin.hs b/Laborantin.hs --- a/Laborantin.hs +++ b/Laborantin.hs @@ -31,18 +31,16 @@ rebrandError (ExecutionError str) = Left $ AnalysisError str -executeExhaustive :: (MonadIO m) => Backend m -> ScenarioDescription m -> m () -executeExhaustive b sc = mapM_ f $ paramSets $ sParams sc +executeExhaustive :: (MonadIO m) => Backend m -> ScenarioDescription m -> [m ()] +executeExhaustive b sc = map f $ paramSets $ sParams sc where f = execute b sc -executeMissing :: (MonadIO m) => Backend m -> ScenarioDescription m -> m () -executeMissing b sc = do - execs <- load b [sc] (B True) - let successful = filter ((== Success) . eStatus) execs - let exhaustive = S.fromList $ paramSets (sParams sc) - let existing = S.fromList $ map eParamSet successful - mapM_ f $ S.toList (exhaustive `S.difference` existing) - where f = execute b sc +executeMissing :: (MonadIO m) => Backend m -> ScenarioDescription m -> [Execution m] -> [m ()] +executeMissing b sc execs = map f $ S.toList (exhaustive `S.difference` existing) + where successful = filter ((== Success) . eStatus) execs + exhaustive = S.fromList $ paramSets (sParams sc) + existing = S.fromList $ map eParamSet successful + f = execute b sc load :: (MonadIO m) => Backend m -> [ScenarioDescription m] -> TExpr Bool -> m [Execution m] load = bLoad diff --git a/Laborantin/CLI.hs b/Laborantin/CLI.hs --- a/Laborantin/CLI.hs +++ b/Laborantin/CLI.hs @@ -25,6 +25,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time (UTCTime(..), getCurrentTime) defaultMain xs = getArgs >>= dispatchR [] >>= runLabor xs @@ -64,10 +65,10 @@ data Labor = Run { scenarii :: [String] , params :: [String] , continue :: Bool , matcher :: [String]} | Describe { scenarii :: [String] } - | Find { scenarii :: [String] , params :: [String] , successful :: Bool, matcher :: [String]} - | Analyze { scenarii :: [String] , params :: [String] , successful :: Bool , matcher :: [String]} - | Rm { scenarii :: [String] , params :: [String] , successful :: Bool , matcher :: [String]} - | Query { scenarii :: [String] , params :: [String] , successful :: Bool , matcher :: [String]} + | Find { scenarii :: [String] , params :: [String] , successful :: Bool, today :: Bool, matcher :: [String]} + | Analyze { scenarii :: [String] , params :: [String] , successful :: Bool , today :: Bool, matcher :: [String]} + | Rm { scenarii :: [String] , params :: [String] , successful :: Bool , today :: Bool, matcher :: [String]} + | Query { scenarii :: [String] , params :: [String] , successful :: Bool , today :: Bool, matcher :: [String]} deriving (Typeable, Data, Show, Eq) instance Attributes Labor where @@ -93,6 +94,11 @@ , Invertible True , Default True ] + , today %> [ Long ["today"] + , Help "Today only (currently uses UTC day!)" + , Invertible True + , Default False + ] , matcher %> [ Short "m" , Long ["matcher"] , Help "Restrict to a matching expression" @@ -133,12 +139,18 @@ statusToTExpr True = (Eq ScStatus (S "success")) statusToTExpr False = Not (Eq ScStatus (S "success")) +todayToTExpr :: Bool -> UTCTime -> TExpr Bool +todayToTExpr True today = (Or (Eq ScTimestamp (T today)) (Gt ScTimestamp (T today))) +todayToTExpr False _ = B True + conjunctionQueries :: [TExpr Bool] -> TExpr Bool conjunctionQueries [] = B True +conjunctionQueries [q] = q conjunctionQueries (q:qs) = And q (conjunctionQueries qs) disjunctionQueries :: [TExpr Bool] -> TExpr Bool disjunctionQueries [] = B False +disjunctionQueries [q] = q disjunctionQueries (q:qs) = Or q (disjunctionQueries qs) filterDescriptions :: DescriptionTExpr -> [ScenarioDescription m] -> [ScenarioDescription m] @@ -147,27 +159,32 @@ runLabor :: [ScenarioDescription EnvIO] -> Labor -> IO () -runLabor xs labor = +runLabor xs labor = do + now <- getCurrentTime case labor of - (Describe scii) -> forM_ xs' (T.putStrLn . describeScenario) - Find {} -> do (execs,_) <- runEnvIO loadMatching - mapM_ (T.putStrLn . describeExecution) execs - (Rm {}) -> runSc loadAndRemove - (Run { continue = False }) -> runSc execAll - (Run { continue = True }) -> runSc execRemaining - Analyze {} -> runSc loadAndAnalyze - Query {} -> putStrLn $ showTExpr $ simplifyOneBoolLevel query + (Describe scii) -> forM_ xs' (T.putStrLn . describeScenario) + Find {} -> do (execs,_) <- runEnvIO (loadMatching now) + mapM_ (T.putStrLn . describeExecution) execs + (Rm {}) -> runSc (loadAndRemove now) + (Run { continue = False }) -> mapM_ runSc allExecs + (Run { continue = True }) -> do (execs,_) <- runEnvIO (loadMatching now) + mapM_ runSc (remainingExecs execs) + Analyze {} -> runSc (loadAndAnalyze now) + Query {} -> do let expr = simplifyOneBoolLevel $ query now + putStrLn $ showTExpr expr - where xs' = filterDescriptions (ScenarioName $ map T.pack $ scenarii labor) xs - matcherUExprs = rights $ map parseUExpr (matcher labor) - matcherTExprs = map (toTExpr (B True)) matcherUExprs - paramsTExpr = paramsToTExpr $ map T.pack $ params labor - scenarioTExpr = scenarsToTExpr $ map T.pack $ scenarii labor - statusTExpr = statusToTExpr $ successful labor - !query = conjunctionQueries (paramsTExpr:scenarioTExpr:statusTExpr:matcherTExprs) - runSc = void . runEnvIO - loadMatching = load defaultBackend xs' query - loadAndRemove = loadMatching >>= mapM (remove defaultBackend) - loadAndAnalyze= loadMatching >>= mapM (executeAnalysis defaultBackend) - execAll = forM_ xs' $ executeExhaustive defaultBackend - execRemaining = forM_ xs' $ executeMissing defaultBackend + where xs' = filterDescriptions (ScenarioName $ map T.pack $ scenarii labor) xs + matcherUExprs = rights $ map parseUExpr (matcher labor) + matcherTExprs = map (toTExpr (B True)) matcherUExprs + paramsTExpr = paramsToTExpr $ map T.pack $ params labor + scenarioTExpr = scenarsToTExpr $ map T.pack $ scenarii labor + statusTExpr = statusToTExpr $ successful labor + dateTExpr tst = todayToTExpr (today labor) (tst {utctDayTime = 0}) + query tst = conjunctionQueries (paramsTExpr:scenarioTExpr:statusTExpr:dateTExpr':matcherTExprs) + where dateTExpr' = dateTExpr tst + runSc = void . runEnvIO + loadMatching tst = load defaultBackend xs' (query tst) + loadAndRemove tst = loadMatching tst >>= mapM (remove defaultBackend) + loadAndAnalyze tst = loadMatching tst >>= mapM (executeAnalysis defaultBackend) + allExecs = concatMap (executeExhaustive defaultBackend) xs' + remainingExecs execs = concatMap (\sc -> executeMissing defaultBackend sc execs) xs' diff --git a/Laborantin/Implementation.hs b/Laborantin/Implementation.hs --- a/Laborantin/Implementation.hs +++ b/Laborantin/Implementation.hs @@ -30,7 +30,7 @@ import System.Log.Handler (close) import System.Log.Handler.Simple import System.Log.Handler.Log4jXML -import System.Time (ClockTime(TOD),getClockTime) +import Data.Time (UTCTime, getCurrentTime) -- | Default monad for 'defaultBackend'. -- EnvIO carries a 'DynEnv' in a state and allows you to perform IO actions. @@ -49,12 +49,6 @@ instance ToJSON ExecutionStatus where toJSON = toJSON . show -instance ToJSON ClockTime where - toJSON (TOD secs ps) = object [ "sec" .= secs - , "ps" .= ps - , "zero" .= ("epoch" :: String) - ] - instance ToJSON (Execution a) where toJSON (Exec sc params path status es tsts) = object [ "scenario-name" .= sName sc , "params" .= params @@ -80,10 +74,6 @@ parseJSON (A.String txt) = return $ read $ T.unpack txt parseJSON _ = mzero -instance FromJSON ClockTime where - parseJSON (A.Object v) = TOD <$> v .: "sec" <*> v .: "ps" - parseJSON _ = mzero - instance FromJSON StoredExecution where parseJSON (A.Object v) = Stored <$> v .: "params" <*> @@ -111,7 +101,7 @@ prepare = prepareNewScenario finalize exec finalizer = do finalizer exec - now <- liftIO $ getClockTime + now <- liftIO $ getCurrentTime let exec' = updateCompletionTime exec now liftIO . putStrLn $ "execution finished\n" liftIO $ BSL.writeFile (rundir ++ "/execution.json") (encode exec') @@ -130,7 +120,7 @@ load = loadExisting -updateCompletionTime :: Execution m -> ClockTime -> Execution m +updateCompletionTime :: Execution m -> UTCTime -> Execution m updateCompletionTime exec t1 = exec {eTimeStamps = (t0,t1)} where t0 = fst $ eTimeStamps exec @@ -143,7 +133,7 @@ prepareNewScenario :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO) prepareNewScenario sc params = do (now,uuid) <- liftIO $ do - now <- getClockTime + now <- getCurrentTime id <- randomIO :: IO UUID return (now,id) let rundir = intercalate "/" [T.unpack (sName sc), show uuid] diff --git a/Laborantin/Query.hs b/Laborantin/Query.hs --- a/Laborantin/Query.hs +++ b/Laborantin/Query.hs @@ -36,6 +36,7 @@ evalExpr exec (L xs) = mapM (evalExpr exec) xs >>= Right evalExpr _ (T x) = Right x evalExpr exec ScName = Right $ sName $ eScenario exec +evalExpr exec ScTimestamp = Right $ fst $ eTimeStamps exec evalExpr exec ScStatus | eStatus exec == Success = Right "success" | eStatus exec == Failure = Right "failure" | eStatus exec == Running = Right "running" @@ -88,6 +89,7 @@ showTExpr (Times e1 e2) = "(" ++ showTExpr e1 ++ " * " ++ showTExpr e2 ++ ")" showTExpr ScName = "@sc.name" showTExpr ScStatus = "@sc.status" +showTExpr ScTimestamp = "@sc.timestamp" showTExpr (ScParam key) = "@sc.param:" ++ show key showTExpr (SCoerce x) = showTExpr x showTExpr (NCoerce x) = showTExpr x diff --git a/Laborantin/Query/Interpret.hs b/Laborantin/Query/Interpret.hs --- a/Laborantin/Query/Interpret.hs +++ b/Laborantin/Query/Interpret.hs @@ -8,7 +8,7 @@ import Laborantin.Query import Data.Text (Text) import Data.Maybe (fromMaybe) -import System.Time (ClockTime) +import Data.Time (UTCTime) type Param = Maybe ParameterValue @@ -17,7 +17,7 @@ TTNum :: TTyp Rational TTString :: TTyp Text TTParam :: TTyp (Text,Param) - TTClock :: TTyp ClockTime + TTUTCTime :: TTyp UTCTime data IError = IError deriving (Show) @@ -42,7 +42,7 @@ interpret UScStatus = Right (ScStatus ::: TTString) interpret (UScParam a) = Right (ScParam a ::: TTParam) interpret (UB a) = Right (B a ::: TTBool) -interpret (UT a) = Right (T a ::: TTClock) +interpret (UT a) = Right (T a ::: TTUTCTime) interpret (UN a) = Right (N a ::: TTNum) interpret (US a) = Right (S a ::: TTString) interpret (UAnd a b) = do diff --git a/Laborantin/Types.hs b/Laborantin/Types.hs --- a/Laborantin/Types.hs +++ b/Laborantin/Types.hs @@ -30,7 +30,7 @@ ) where import qualified Data.Map as M -import System.Time (ClockTime) +import Data.Time (UTCTime) import Control.Monad.Reader import Control.Monad.Error import Data.Dynamic @@ -91,7 +91,7 @@ , ePath :: FilePath , eStatus :: ExecutionStatus , eAncestors :: [Execution m] - , eTimeStamps :: (ClockTime,ClockTime) + , eTimeStamps :: (UTCTime,UTCTime) } deriving (Show) data StoredExecution = Stored { @@ -99,7 +99,7 @@ , sePath :: FilePath , seStatus :: ExecutionStatus , seAncestors :: [(FilePath,Text)] - , seTimeStamps :: (ClockTime,ClockTime) + , seTimeStamps :: (UTCTime,UTCTime) } deriving (Show) data Dependency m = Dep { @@ -158,7 +158,7 @@ B :: Bool -> TExpr Bool S :: Text -> TExpr Text L :: [TExpr a] -> TExpr [a] - T :: ClockTime -> TExpr ClockTime + T :: UTCTime -> TExpr UTCTime Plus :: TExpr Rational -> TExpr Rational -> TExpr Rational Times :: TExpr Rational -> TExpr Rational -> TExpr Rational And :: TExpr Bool -> TExpr Bool -> TExpr Bool @@ -170,6 +170,7 @@ ScName :: TExpr Text ScStatus :: TExpr Text ScParam :: Text -> TExpr (Text, Maybe ParameterValue) + ScTimestamp :: TExpr UTCTime SCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Text NCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Rational SilentSCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Text @@ -180,7 +181,7 @@ | UB Bool | US Text | UL [UExpr] - | UT ClockTime + | UT UTCTime | UPlus UExpr UExpr | UMinus UExpr UExpr | UTimes UExpr UExpr diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -112,15 +112,16 @@ # Roadmap -For version 1. +For version 1.2 -* Parse clocktime -* Debug errors in -* Function to expand TExpr to parameter space (for run command) -* Selector to load prior results based on a TExpr +* Syntax to parse clocktime and with --date=today/this-week etc. types of flags +* Print better debug errors on parsing messages +* Function to expand an UExpr (or a TExpr ([(ParameterName,ParameterValue)]))into a ParameterSpace + - then need a function to extend a ParameterSpace with default values + ScenarioDescription -> ParameterSpace -> ParameterSpace +* Add a scSelector :: TExpr Bool field to a scenario to load ancestors at prepare-time - "require" helper that sets a dep + selection * exports to propose exported files using "show-exports" command # Annoyances/Bugs -* DynEnv shared for the whole runEnvIO, need to have one DynEnv per-execution - +* the "continue" mode doesn't do what it should anymore, don't use it for now diff --git a/laborantin-hs.cabal b/laborantin-hs.cabal --- a/laborantin-hs.cabal +++ b/laborantin-hs.cabal @@ -2,9 +2,51 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: laborantin-hs -version: 0.1.1.3 +version: 0.1.2.0 synopsis: an experiment management framework --- description: +description: + Laborantin is a framework and DSL to run and manage results from scientific + experiments. Good targets for Laborantin are experiments that you can + run /offline/ such as benchmark and batch analytics. + . + Writing experiments with Laborantin has at least two advantages over + rolling your own scripts. First, Laborantain standardizes the workflow of your + experimentations. There is one-way to describe what a project can do, what + experiments where already run, how to delete files corresponding to a specific + experiment etc. Second, Laborantin builds on years of experience running + experiments. Using Laborantin should alleviates common pain points such as + querying for experiments, managing dependencies between results + . + Laborantin's DSL lets you express experiment parameters, + setup, teardown, and recovery hooks in a systematic way. + In addition, this DSL let you express dependencies on your + experiments so that you can run prior experiments or data analyses. + . + Laborantin comes with a default backend that stores + experiment results in a filesystem-hierarchy. Laborantin + also comes with a default command-line that let you + specify which experiments to run, analyze, or delete. + . + > ping :: ScenarioDescription EnvIO + > ping = scenario "ping" $ do + > describe "ping to a remote server" + > parameter "destination" $ do + > describe "a destination server (host or ip)" + > values [str "example.com", str "probecraft.net"] + > parameter "packet-size" $ do + > describe "packet size in bytes" + > values [num 50, num 1500] + > run $ do + > (StringParam srv) <- param "destination" + > (StringParam ps) <- param "packet-size" + > liftIO (executePingCommand srv ps) >>= writeResult "raw-result" + > where executePingCommand :: Text -> Rational -> IO (Text) + > executePingCommand host packetSize = ... + > + > main :: IO () + > main = defaultMain [ping] + + homepage: https://github.com/lucasdicioccio/laborantin-hs license: Apache-2.0 license-file: LICENSE @@ -20,7 +62,7 @@ exposed-modules: Laborantin, Laborantin.DSL, Laborantin.Implementation, Laborantin.Types, Laborantin.CLI, Laborantin.Query other-modules: Laborantin.Query.Parse, Laborantin.Query.Interpret other-extensions: FlexibleContexts, OverloadedStrings, TupleSections - build-depends: base >=4.6 && <4.7, transformers >=0.3 && <0.4, mtl >=2.1 && <2.2, containers >=0.5 && <0.6, text >=0.11 && <0.12, bytestring >=0.10 && <0.11, aeson >=0.6 && <0.7, uuid >=1.2 && <1.3, directory >=1.2 && <1.3, random >=1.0 && <1.1, hslogger >=1.2 && <1.3, cmdlib >= 0.3.5, split >= 0.2.2, old-time >= 1.1.0.0, parsec >= 3.1.0 + build-depends: base >=4.6 && <4.7, transformers >=0.3 && <0.4, mtl >=2.1 && <2.2, containers >=0.5 && <0.6, text >=0.11 && <0.12, bytestring >=0.10 && <0.11, aeson >=0.6 && <0.7, uuid >=1.2 && <1.3, directory >=1.2 && <1.3, random >=1.0 && <1.1, hslogger >=1.2 && <1.3, cmdlib >= 0.3.5, split >= 0.2.2, time >= 1.4.0.1, parsec >= 3.1.0 -- hs-source-dirs: default-language: Haskell2010