laborantin-hs 0.1.3.0 → 0.1.4.0
raw patch · 8 files changed
+177/−27 lines, 8 files
Files
- Laborantin/CLI.hs +3/−1
- Laborantin/DSL.hs +37/−3
- Laborantin/Implementation.hs +32/−2
- Laborantin/Query/Parse.hs +22/−9
- Laborantin/Types.hs +73/−1
- README.md +5/−2
- examples/main.hs +4/−8
- laborantin-hs.cabal +1/−1
Laborantin/CLI.hs view
@@ -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
Laborantin/DSL.hs view
@@ -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)
Laborantin/Implementation.hs view
@@ -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"))
Laborantin/Query/Parse.hs view
@@ -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"
Laborantin/Types.hs view
@@ -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
README.md view
@@ -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
examples/main.hs view
@@ -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)
laborantin-hs.cabal view
@@ -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