diff --git a/Laborantin/CLI.hs b/Laborantin/CLI.hs --- a/Laborantin/CLI.hs +++ b/Laborantin/CLI.hs @@ -26,6 +26,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time (UTCTime(..), getCurrentTime) +import System.Locale defaultMain xs = getArgs >>= dispatchR [] >>= runLabor xs @@ -200,7 +201,8 @@ print expr where xs' = filterDescriptions (ScenarioName $ map T.pack $ scenarii labor) xs - matcherUExprs = rights $ map parseUExpr (matcher labor) + prefs = ParsePrefs defaultTimeLocale + matcherUExprs = rights $ map (parseUExpr prefs) (matcher labor) matcherTExprs = map (toTExpr (B True)) matcherUExprs paramsTExpr = paramsToTExpr $ map T.pack $ params labor scenarioTExpr = scenarsToTExpr $ map T.pack $ scenarii labor diff --git a/Laborantin/DSL.hs b/Laborantin/DSL.hs --- a/Laborantin/DSL.hs +++ b/Laborantin/DSL.hs @@ -18,7 +18,12 @@ , setup , teardown , run + , self + , backend , param + , ancestors + , ancestorsMatching + , ancestorsMatchingTExpr , getVar , setVar , recover @@ -59,9 +64,15 @@ changeDescription d dep = dep { dDesc = d } -- | DSL entry point to build a 'ScenarioDescription'. -scenario :: Text -> State (ScenarioDescription m) () -> ScenarioDescription m +scenario :: (Monad m) => Text -> State (ScenarioDescription m) () -> ScenarioDescription m scenario name f = execState f sc0 - where sc0 = SDesc name "" M.empty M.empty Nothing [] (B False) + where sc0 = emptyScenario { sName = name, sHooks = defaultNoHooks } + where defaultNoHooks = M.fromList [ ("setup", noop) + , ("teardown", noop) + , ("run", noop) + , ("analyze", noop) + ] + noop = Action (return ()) -- | Attach a description to the 'Parameter' / 'Scnario' describe :: Describable a => Text -> State a () @@ -166,9 +177,17 @@ -- | Defines the TExpr Bool to load ancestor require :: (MonadIO m, Monad m) => ScenarioDescription m -> Text -> State (ScenarioDescription m) () require sc txt = requireTExpr sc query - where query = either (const deflt) (toTExpr deflt) (parseUExpr (unpack txt)) + where query = either (const deflt) (toTExpr deflt) (parseUExpr defaultParsePrefs (unpack txt)) deflt = (B True) +-- | Returns current execution +self :: Monad m => Step m (Execution m) +self = liftM snd ask + +-- | Returns current backend +backend :: Monad m => Step m (Backend m) +backend = liftM fst ask + -- | Returns a 'Result' object for the given name. -- -- Implementations will return their specific results. @@ -236,3 +255,18 @@ -> m (Maybe v) getVar k = maybe Nothing fromDynamic <$> getVar' k +-- | Get all ancestors for a given scenario name and matching a TExpr Bool query. +ancestorsMatchingTExpr :: (Monad m) => Text -> TExpr Bool -> Step m [Execution m] +ancestorsMatchingTExpr name query = liftM (matching . eAncestors . snd) ask + where matching = filter (matchTExpr query) + +-- | Get all ancestors for a given scenario name and matching a query expressed as a string. +-- Current implementation silences errors. +ancestorsMatching :: (Monad m) => Text -> Text -> Step m [Execution m] +ancestorsMatching name txt = ancestorsMatchingTExpr name query + where query = either (const deflt) (toTExpr deflt) (parseUExpr defaultParsePrefs (unpack txt)) + deflt = (B False) + +-- | Get all ancestors for a given scenario name. +ancestors :: (Monad m) => Text -> Step m [Execution m] +ancestors = flip ancestorsMatchingTExpr (B True) diff --git a/Laborantin/Implementation.hs b/Laborantin/Implementation.hs --- a/Laborantin/Implementation.hs +++ b/Laborantin/Implementation.hs @@ -123,22 +123,30 @@ load = loadExisting +-- | Modifies the the second timestamp of an Execution updateCompletionTime :: Execution m -> UTCTime -> Execution m updateCompletionTime exec t1 = exec {eTimeStamps = (t0,t1)} where t0 = fst $ eTimeStamps exec +-- | Returns a Text advertising the Execution advertise :: Execution m -> Text advertise exec = T.pack $ unlines [ "scenario: " ++ (show . sName . eScenario) exec , " rundir: " ++ ePath exec , " json-params: " ++ (C.unpack . encode . eParamSet) exec ] +-- | Helper to print a Show instance with a prefix bPrint :: (MonadIO m, Show a) => a -> m () bPrint = liftIO . putStrLn . ("backend> " ++) . show +-- | Helper to print a Text with a prefix bPrintT :: (MonadIO m) => Text -> m () bPrintT = liftIO . T.putStrLn . (T.append "backend> ") +-- | Prepare a new Scenario for a given ParameterSet. Default implementation. +-- Creates an UUID and takes a timestamp. +-- Try resolving dependencies. +-- If successful, creates a directory to hold the result and provision a logger. prepareNewScenario :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO) prepareNewScenario sc params = do bPrint $ T.append "preparing " (sName sc) @@ -146,7 +154,7 @@ now <- getCurrentTime id <- randomIO :: IO UUID return (now,id) - let rundir = intercalate "/" [T.unpack (sName sc), show uuid] + let rundir = intercalate "/" ["results", T.unpack (sName sc), show uuid] let newExec = Exec sc params rundir Running [] (now,now) bPrint "resolving dependencies" exec <- resolveDependencies newExec @@ -161,12 +169,29 @@ return [h1,h2] return (exec, \_ -> liftIO $ forM_ handles close) +-- | Resolve dependencies for an Execution or fail using error (unsafely) if it +-- didn't succeed. resolveDependencies :: Execution EnvIO -> EnvIO (Execution EnvIO) resolveDependencies exec = do pending <- getPendingDeps exec deps resolveDependencies' exec [] pending where deps = sDeps $ eScenario exec +-- | Actual implementation for the dependency resolution. +-- +-- Iteratively tries dependencies. +-- If there is no dependency left, suceed. +-- Else tries the first unmet dependency pending. +-- If the dependency failed, with no other unmet dependeny, error the program. +-- If the dependency succeed, restart with all still unmet dependencies. +-- If the dependency failed with other unmet dependency, reiterate until one succeeds or the program goes on error. +-- +-- A reason why we error the program is that at the time of the check, there +-- should be no running experiments and we can easily notify the user. +-- As there often are correlation between a batch of experiments, one unmet +-- depedency is likely to impede other executions as well. Hence current choice +-- to crash early. +-- resolveDependencies' :: Execution EnvIO -> [Dependency EnvIO] -> [Dependency EnvIO] -> EnvIO (Execution EnvIO) resolveDependencies' exec [] [] = return exec resolveDependencies' exec failed [] = error "cannot solve dependencies" @@ -191,12 +216,13 @@ bPrintT $ T.append "checking " (dName dep) dCheck dep exec +-- | Load existing executions for a query and and a list of scenarios descriptions. loadExisting :: [ScenarioDescription EnvIO] -> TExpr Bool -> EnvIO [Execution EnvIO] loadExisting scs qexpr = do concat <$> mapM f scs where f :: ScenarioDescription EnvIO -> EnvIO [Execution EnvIO] f sc = do - paths <- map ((name ++ "/") ++) . filter notDot <$> liftIO (getDirectoryContents' name) + paths <- map (("results/" ++ name ++ "/") ++) . filter notDot <$> liftIO (getDirectoryContents' $ "results/" ++ name) allExecs <- mapM (loadOne sc scs) paths return $ filter (matchTExpr qexpr) allExecs where notDot dirname = take 1 dirname /= "." @@ -205,6 +231,10 @@ getDirectoryContents' dir = catchIOError (getDirectoryContents dir) (\e -> if isDoesNotExistError e then return [] else ioError e) +-- | Load one execution at a given path for a given scenario. +-- +-- If could not decode the execution, error the program, this should happen +-- only when file got corrupted/software changed too much. loadOne :: ScenarioDescription EnvIO -> [ScenarioDescription EnvIO] -> FilePath -> EnvIO (Execution EnvIO) loadOne sc scs path = do stored <- decode <$> liftIO (BSL.readFile (path ++ "/execution.json")) diff --git a/Laborantin/Query/Parse.hs b/Laborantin/Query/Parse.hs --- a/Laborantin/Query/Parse.hs +++ b/Laborantin/Query/Parse.hs @@ -1,6 +1,11 @@ {-# LANGUAGE TupleSections #-} -module Laborantin.Query.Parse (expr, parseUExpr) where +module Laborantin.Query.Parse ( + expr + , ParsePrefs (..) + , defaultParsePrefs + , parseUExpr + ) where import Laborantin.Types (UExpr (..)) import Laborantin.Query @@ -14,18 +19,25 @@ import Data.Time import Data.Time.Format -parseUExpr :: String -> Either ParseError UExpr -parseUExpr = parse expr "" +data ParsePrefs = ParsePrefs { + prefTimeLocale :: TimeLocale + } deriving (Show) -expr :: Parsec String u UExpr +defaultParsePrefs :: ParsePrefs +defaultParsePrefs = ParsePrefs defaultTimeLocale + +parseUExpr :: ParsePrefs -> String -> Either ParseError UExpr +parseUExpr prefs str = runP expr prefs "-" str + +expr :: Parsec String ParsePrefs UExpr expr = foldl chainl1 term [try inclOp, try mulOp, try addOp, try compOp, try boolOp] where term = expr' <|> negated <|> ary <|> literal <|> special where expr' = char '(' *> expr <* char ')' -negated :: Parsec String u UExpr +negated :: Parsec String ParsePrefs UExpr negated = UNot <$> (spaces *> char '!' *> spaces *> expr) -ary :: Parsec String u UExpr +ary :: Parsec String ParsePrefs UExpr ary = UL <$> (char '[' *> (expr `sepBy` (spaces >> char ',' >> spaces)) <* char ']') binOp xs = do @@ -40,14 +52,15 @@ compOp = binOp [(">=",UGte),(">",UGt),("==",UEq),("<=",ULte),("<",ULt)] inclOp = binOp [("in",UContains), ("~>",UContains)] -literal :: Parsec String u UExpr +literal :: Parsec String ParsePrefs UExpr literal = try bool <|> date <|> (UN <$> number) <|> (US . T.pack <$> quotedString) -date :: Parsec String u UExpr +date :: Parsec String ParsePrefs UExpr date = do string "t:" str <- quotedString - let parsed = parseTimeFormats' defaultTimeLocale fmts str + timeLocale <- prefTimeLocale <$> getState + let parsed = parseTimeFormats' timeLocale fmts str case parsed of [x] -> return $ UT x _ -> fail "invalid time format" diff --git a/Laborantin/Types.hs b/Laborantin/Types.hs --- a/Laborantin/Types.hs +++ b/Laborantin/Types.hs @@ -45,10 +45,12 @@ import qualified Data.Text as T import Data.List (nub) +-- | DynEnv is a map between Text keys and Dynamic values. type DynEnv = M.Map Text Dynamic emptyEnv :: DynEnv emptyEnv = M.empty +-- | A ParameterSpace maps parameter names to their descriptions. type ParameterSpace = M.Map Text ParameterDescription data ExecutionError = ExecutionError String deriving (Show) @@ -60,8 +62,14 @@ instance Error AnalysisError where noMsg = AnalysisError "A String Error!" strMsg = AnalysisError + + +-- | A step is a stateful operation for a Scenario phase. +-- It carries a modifiable DynEnv between hooks and handle ExecutionErrors. +-- In addition, you can read (but not modify) the Backend and the Execution. type Step m a = (ErrorT ExecutionError (StateT DynEnv (ReaderT (Backend m,Execution m) m)) a) +-- | An Action wraps a monadic computation inside a step. newtype Action m = Action { unAction :: Step m () } instance Show (Action m) where @@ -70,6 +78,7 @@ instance Show (ExecutionError -> Action m) where show _ = "(Error-recovery action)" +-- | A Scenario description carries all information to run an experiment. data ScenarioDescription m = SDesc { sName :: Text , sDesc :: Text @@ -83,6 +92,8 @@ emptyScenario :: ScenarioDescription m emptyScenario = SDesc "" "" M.empty M.empty Nothing [] noQuery +-- | A ParameterDescription description carries information for a single +-- parameter. data ParameterDescription = PDesc { pName :: Text , pDesc :: Text @@ -92,17 +103,33 @@ emptyParameter :: ParameterDescription emptyParameter = PDesc "" "" [] +-- | Two parameter values type should be enough for command-line demands: text +-- and numbers. +-- +-- However, we provide two other constructors (Array and Range) for the +-- ParameterDescriptions in the DSL. +-- +-- Executions should use text and numbers only. data ParameterValue = StringParam Text | NumberParam Rational | Array [ParameterValue] | Range Rational Rational Rational -- [from, to], by increment deriving (Show,Eq,Ord) +-- | A ParameterSet (slightly different from a ParameterSpace) is a mapping +-- between parameter names and a single ParameterValue. +-- +-- You can see a ParameterSet as a datapoint within a (multidimensional) +-- ParameterSpace. +-- +-- Thus, to keep things clearer, we recommend that executions use only text and +-- numbers as ParameterValues. type ParameterSet = M.Map Text ParameterValue data ExecutionStatus = Running | Success | Failure deriving (Show,Read,Eq) +-- | An Execution represents an ongoing or past experiment result. data Execution m = Exec { eScenario :: ScenarioDescription m , eParamSet :: ParameterSet @@ -112,6 +139,11 @@ , eTimeStamps :: (UTCTime,UTCTime) } deriving (Show) +-- | An StoredExecution is a stripped-down version of an Execution. +-- +-- As it represents an experiment stored on disk, it does not need to carry the +-- ScenarioDescription object (otherwise it would become harder to create +-- instances such as FromJSON for Executions). data StoredExecution = Stored { seParamSet :: ParameterSet , sePath :: FilePath @@ -120,6 +152,24 @@ , seTimeStamps :: (UTCTime,UTCTime) } deriving (Show) +-- | A Dependency is a lose but flexible way of expressing dependencies for +-- experiments. +-- +-- Dependencies can check whether they are fullfilled, and try to solve. +-- The main goal for the design of Dependency dCheck and dSolve hooks is to let +-- a Dependency run experiments and add them as ancestors *before* starting any +-- Step. Types may slightly vary in the future. +-- +-- Dependencies can do anything that a ScenarioDescription allows (hence they +-- are parametrized with the same monad as the ScenarioDescription owning a +-- Dependency). However, Dependency check and Dependency resolution do not live +-- in a Step m . That is they do not have access to, and cannot modify, the +-- DynEnv. Thus, this limits the possibility to read execution parameters from +-- within the dCheck and dSolve. +-- +-- To compensate for this limitation, the dCheck hook accepts the Execution as +-- parameter and the dSolve hook accepts both the Execution and the Backend as +-- parameter, and get a chance to return a modified Execution object. data Dependency m = Dep { dName :: Text , dDesc :: Text @@ -137,26 +187,43 @@ ++ show (dDesc dep) ++ "}" +-- | Expands a ParameterValue to a list of ParameterValues. +-- Mainly flattens ranges. expandValue :: ParameterValue -> [ParameterValue] expandValue (Range from to by) = map NumberParam [from,from+by .. to] expandValue x = [x] +-- | Returns an exhaustive list of ParameterSet (i.e., all data points) to +-- cover a (multidimensional) ParameterSpace. +-- +-- Basically a Cartesian product. paramSets :: ParameterSpace -> [ParameterSet] paramSets ps = map M.fromList $ sequence possibleValues where possibleValues = map f $ M.toList ps f (k,desc) = concatMap (map (pName desc,) . expandValue) $ pValues desc type Finalizer m = Execution m -> m () +-- | Merges two ParameterSpace by extending all dimensions. mergeParamSpaces :: ParameterSpace -> ParameterSpace -> ParameterSpace mergeParamSpaces ps1 ps2 = M.mergeWithKey f id id ps1 ps2 where f k v1 v2 = Just (v1 { pValues = values }) where values = nub $ (pValues v1) ++ (pValues v2) --- | +-- | Updates a single dimension of the ParameterSpace to be the list of +-- ParameterValue s in 3rd parameter. updateParam :: ParameterSpace -> Text -> [ParameterValue] -> ParameterSpace updateParam ps key values = M.updateWithKey f key ps where f k param = Just (param {pValues = values}) +-- | A Backend captures all functions that an object must provide to run +-- Laborantin experiments. +-- +-- Such functions give ways to prepare, run, analyze, and finalize executions. +-- As well as provide support for logging info, storing, +-- finding, and deleting prior results. +-- +-- We prefer such a design over a typeclass to simplify overall design and +-- unclutter type definitions everywhere. data Backend m = Backend { bName :: Text , bPrepareExecution :: ScenarioDescription m -> ParameterSet -> m (Execution m,Finalizer m) @@ -172,6 +239,11 @@ , bRemove :: Execution m -> m () } +-- | Backends must generate results that are easy to operate. They represent +-- files with read/write/append operations as execution steps. +-- +-- Note that Backend might not implement all three of read, write, append +-- operations. data Result m = Result { pPath :: FilePath , pRead :: Step m Text diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -112,8 +112,11 @@ # Roadmap -For version 0.1.4.x +For version 0.1.5.x -* [improvement] Use './results' as root dir in defaultBackend * [improvement] Use system locale rather than default locale for time parsing + - actually might not be such a good idea, let everyone input %d/%d/%y * [feature] exports to propose exported files using "show-exports" command +* [feature] labor-script binary for easy-integration of other scripts + - will need to expand parameter spaces by extending undeclared parameters +* [code] cleanup/share/unshare parts of implementation/laborantin/cli script diff --git a/examples/main.hs b/examples/main.hs --- a/examples/main.hs +++ b/examples/main.hs @@ -18,11 +18,6 @@ parameter "foo" $ do describe "foo" values [str "foo"] - setup (return ()) - run (return ()) - teardown (return ()) - recover (const (return ())) - analyze (return ()) ping :: ScenarioDescription EnvIO ping = scenario "ping" $ do @@ -30,7 +25,7 @@ require pong "@sc.param 'foo' == 'foo'" parameter "destination" $ do describe "a destination server (host or ip)" - values [str "example.com", str "probecraft.net", str "nonexistent"] + values [str "example.com", str "probecraft.net"] parameter "packet-size" $ do describe "packet size in bytes" values [num 50, num 1500] @@ -41,12 +36,13 @@ setVar "hello" ("world"::String) dbg "setting up scenario" run $ do + ancestors "pong" >>= liftIO . print . (\n -> show n ++ " ancestor(s)") . length (Just str :: Maybe String) <- getVar "hello" liftIO . print . ("hello "++) $ str (StringParam srv) <- param "destination" case srv of - "nonexistent" -> err "noooo" - str -> dbg $ T.append "mimic sending ping to " str + "failure.example" -> err "noooo" + str -> dbg $ T.append "mimic sending ping to " str writeResult "raw-result" "a sort of result stored as a separate file" teardown $ dbg "here we could run some teardown action" recover $ \err -> dbg $ T.append "here we could recover from error: " (T.pack $ show err) diff --git a/laborantin-hs.cabal b/laborantin-hs.cabal --- a/laborantin-hs.cabal +++ b/laborantin-hs.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: laborantin-hs -version: 0.1.3.0 +version: 0.1.4.0 synopsis: an experiment management framework description: Laborantin is a framework and DSL to run and manage results from scientific