laborantin-hs 0.1.1.2 → 0.1.1.3
raw patch · 11 files changed
+734/−148 lines, 11 filesdep +laborantin-hsdep +old-timedep +parsecnew-component:exe:labor-example
Dependencies added: laborantin-hs, old-time, parsec
Files
- Laborantin.hs +2/−2
- Laborantin/CLI.hs +81/−52
- Laborantin/DSL.hs +47/−20
- Laborantin/Implementation.hs +110/−42
- Laborantin/Query.hs +125/−0
- Laborantin/Query/Interpret.hs +129/−0
- Laborantin/Query/Parse.hs +74/−0
- Laborantin/Types.hs +95/−19
- README.md +10/−9
- examples/main.hs +50/−0
- laborantin-hs.cabal +11/−4
Laborantin.hs view
@@ -37,14 +37,14 @@ executeMissing :: (MonadIO m) => Backend m -> ScenarioDescription m -> m () executeMissing b sc = do- execs <- load b sc+ 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 -load :: (MonadIO m) => Backend m -> ScenarioDescription m -> m [Execution m]+load :: (MonadIO m) => Backend m -> [ScenarioDescription m] -> TExpr Bool -> m [Execution m] load = bLoad remove :: (MonadIO m) => Backend m -> Execution m -> m ()
Laborantin/CLI.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} module Laborantin.CLI (defaultMain) where@@ -8,56 +10,64 @@ import Laborantin import Laborantin.Types import Laborantin.Implementation+import Laborantin.Query+import Laborantin.Query.Parse+import Laborantin.Query.Interpret import System.Environment import System.Console.CmdLib hiding (run) import qualified Data.Map as M import Data.List (intercalate) import Data.Aeson (encode) import Data.Maybe (catMaybes)+import Data.Either (rights) import qualified Data.ByteString.Lazy.Char8 as C import Data.List.Split (splitOn)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T defaultMain xs = getArgs >>= dispatchR [] >>= runLabor xs -unlines' :: [String] -> String-unlines' = intercalate "\n"+unlines' :: [Text] -> Text+unlines' = T.intercalate "\n" -describeScenario :: ScenarioDescription m -> String-describeScenario sc = unlines [- "# Scenario: " ++ sName sc- , " " ++ sDesc sc- , " " ++ (show . length . paramSets $ sParams sc) ++ " parameter combinations by default"+describeScenario :: ScenarioDescription m -> Text+describeScenario sc = T.unlines [+ T.append "# Scenario: " (sName sc)+ , T.append " " (sDesc sc)+ , T.concat [" ", (T.pack . show . length . paramSets $ sParams sc), " parameter combinations by default"] , "## Parameters:" , unlines' $ paramLines ] where paramLines = map (uncurry paramLine) pairs pairs = M.toList $ sParams sc paramLine n p = unlines' [- "### " ++ n+ T.append "### " n , describeParameter p ] -describeParameter :: ParameterDescription -> String+describeParameter :: ParameterDescription -> Text describeParameter p = unlines' [- "(" ++ pName p ++ ")"- , " " ++ pDesc p- , " " ++ (show . length $ concatMap expandValue $ pValues p) ++ " values:"- , unlines $ map ((" - " ++) . show) (pValues p)+ T.concat ["(", pName p , ")"]+ , T.concat [" ", pDesc p]+ , T.concat [" ", (T.pack . show . length $ concatMap expandValue $ pValues p), " values:"]+ , T.pack $ unlines $ map ((" - " ++) . show) (pValues p) ] -describeExecution :: Execution m -> String-describeExecution e = intercalate " " [ ePath e- , sName (eScenario e)+describeExecution :: Execution m -> Text+describeExecution e = T.pack $ intercalate " " [ ePath e+ , T.unpack $ sName (eScenario e) , "(" ++ show (eStatus e) ++ ")" , C.unpack $ encode (eParamSet e) ] -data Labor = Run { scenarii :: [String] , params :: [String] , continue :: Bool} +data Labor = Run { scenarii :: [String] , params :: [String] , continue :: Bool , matcher :: [String]} | Describe { scenarii :: [String] } - | Find { scenarii :: [String] , params :: [String] } - | Analyze { scenarii :: [String] , params :: [String] } - | Rm { scenarii :: [String] , params :: [String] , force :: Bool , failed :: Bool , successful :: Bool} + | 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]} deriving (Typeable, Data, Show, Eq) instance Attributes Labor where@@ -78,67 +88,86 @@ , Invertible True , Help "Continue execution (skip known)" ]- , force %> [ Short "f"- , Long ["force"]- , Help "Force flag"- ]- , failed %> [ Long ["failed"]- , Help "Failed only"- ] , successful %> [ Long ["successful"] , Help "Successful only"+ , Invertible True+ , Default True ]+ , matcher %> [ Short "m"+ , Long ["matcher"]+ , Help "Restrict to a matching expression"+ , ArgHelp "MATCHER EXPRESSION"+ ] ] instance RecordCommand Labor where mode_summary _ = "Laborantin command-line interface"+ run' = error "should not arrive here" -data DescriptionQuery = ScenarioName [String]+data DescriptionTExpr = ScenarioName [Text] deriving (Show) -type ExecutionQuery = M.Map String [ParameterValue]--parseParamQuery :: String -> Maybe (String,[ParameterValue])-parseParamQuery str = let vals = splitOn ":" str in+parseParamTExpr :: Text -> Maybe (TExpr Bool)+parseParamTExpr str = let vals = T.splitOn ":" str in case vals of- [k,"int",v] -> Just (k, [NumberParam . toRational $ read v])- [k,"double",v] -> Just (k, [NumberParam . toRational $ (read v :: Double)])- [k,"rational",v] -> Just (k, [NumberParam $ read v])- [k,"str",v] -> Just (k, [StringParam v])+ [k,"ratio",v] -> Just (Eq (NCoerce (ScParam k)) (N $ unsafeReadText v))+ [k,"int",v] -> Just (Eq (NCoerce (ScParam k)) (N . toRational $ unsafeReadText v))+ [k,"float",v] -> Just (Eq (NCoerce (ScParam k)) (N $ toRational (unsafeReadText v :: Float)))+ [k,"str",v] -> Just (Eq (SCoerce (ScParam k)) (S v)) _ -> Nothing -paramsToQuery :: [String] -> ExecutionQuery-paramsToQuery xs = let pairs = catMaybes (map parseParamQuery xs) in- M.fromListWith (++) pairs+ where unsafeReadText :: (Read a) => Text -> a + unsafeReadText = read . T.unpack -filterDescriptions :: DescriptionQuery -> [ScenarioDescription m] -> [ScenarioDescription m]+paramsToTExpr :: [Text] -> TExpr Bool+paramsToTExpr xs = let atoms = catMaybes (map parseParamTExpr xs) in+ conjunctionQueries atoms++-- if no scenario: True, otherwise any of the scenarios+scenarsToTExpr :: [Text] -> TExpr Bool+scenarsToTExpr [] = B True+scenarsToTExpr scii = let atoms = map (\name -> (Eq ScName (S name))) scii in+ disjunctionQueries atoms++statusToTExpr :: Bool -> TExpr Bool+statusToTExpr True = (Eq ScStatus (S "success"))+statusToTExpr False = Not (Eq ScStatus (S "success"))++conjunctionQueries :: [TExpr Bool] -> TExpr Bool+conjunctionQueries [] = B True+conjunctionQueries (q:qs) = And q (conjunctionQueries qs)++disjunctionQueries :: [TExpr Bool] -> TExpr Bool+disjunctionQueries [] = B False+disjunctionQueries (q:qs) = Or q (disjunctionQueries qs)++filterDescriptions :: DescriptionTExpr -> [ScenarioDescription m] -> [ScenarioDescription m] filterDescriptions (ScenarioName []) xs = xs filterDescriptions (ScenarioName ns) xs = filter ((flip elem ns) . sName) xs -filterExecutions :: ExecutionQuery -> [Execution m] -> [Execution m]-filterExecutions query = filter (matchQuery query . eParamSet) -matchQuery :: ExecutionQuery -> ParameterSet -> Bool-matchQuery m params = all id $ map snd $ M.toList $ M.intersectionWith elem params m- runLabor :: [ScenarioDescription EnvIO] -> Labor -> IO () runLabor xs labor = case labor of- (Describe scii) -> forM_ xs' (putStrLn . describeScenario)+ (Describe scii) -> forM_ xs' (T.putStrLn . describeScenario) Find {} -> do (execs,_) <- runEnvIO loadMatching- mapM_ (putStrLn . describeExecution) execs+ 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 - where xs' = filterDescriptions (ScenarioName $ scenarii labor) xs- query = paramsToQuery $ params labor+ 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- loadAll = concat <$> mapM (load defaultBackend) xs'- loadMatching = filterExecutions query <$> loadAll+ 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-
Laborantin/DSL.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Laborantin.DSL ( scenario , describe , parameter+ , dependency+ , check+ , resolve , values , str , num@@ -32,9 +36,10 @@ import Control.Monad.Error import Control.Applicative import Data.Dynamic+import Data.Text (Text, unpack) class Describable a where- changeDescription :: String -> a -> a+ changeDescription :: Text -> a -> a instance Describable (ScenarioDescription a) where changeDescription d sc = sc { sDesc = d }@@ -42,30 +47,52 @@ instance Describable ParameterDescription where changeDescription d pa = pa { pDesc = d } +instance Describable (Dependency a) where+ changeDescription d dep = dep { dDesc = d }+ -- | DSL entry point to build a 'ScenarioDescription'.-scenario :: String -> State (ScenarioDescription m) () -> ScenarioDescription m+scenario :: Text -> State (ScenarioDescription m) () -> ScenarioDescription m scenario name f = execState f sc0- where sc0 = SDesc name "" M.empty M.empty Nothing+ where sc0 = SDesc name "" M.empty M.empty Nothing [] -- | Attach a description to the 'Parameter' / 'Scnario'-describe :: Describable a => String -> State a ()+describe :: Describable a => Text -> State a () describe desc = modify (changeDescription desc) -- | DSL entry point to build a 'ParameterDescription' within a scenario.-parameter :: String -> State ParameterDescription () -> State (ScenarioDescription m) ()+parameter :: Text -> State ParameterDescription () -> State (ScenarioDescription m) () parameter name f = modify (addParam name param) where addParam k v sc0 = sc0 { sParams = M.insert k v (sParams sc0) } param = execState f param0 where param0 = PDesc name "" [] +-- | DSL entry point to build a 'Dependency a' within a scenario.+dependency :: (Monad m) => Text -> State (Dependency m) () -> State (ScenarioDescription m) ()+dependency name f = modify (addDep dep)+ where addDep v sc0 = sc0 { sDeps = v:(sDeps sc0)}+ dep = execState f dep0+ where dep0 = Dep name "" (const (return True)) (const (return ()))++-- | Set verification action for the dependency+check :: (Execution m -> m Bool) -> State (Dependency m) ()+check f = do+ dep0 <- get+ put $ dep0 { dCheck = f }++-- | Set resolution action for the dependency+resolve :: (Execution m -> m ()) -> State (Dependency m) ()+resolve f = do+ dep0 <- get+ put $ dep0 { dSolve = f }+ -- | Set default values for the paramater values :: [ParameterValue] -> State ParameterDescription () values xs = do param0 <- get put $ param0 { pValues = xs } --- | Encapsulate a String as a 'ParameterValue'-str :: String -> ParameterValue+-- | Encapsulate a Text as a 'ParameterValue'+str :: Text -> ParameterValue str = StringParam -- | Encapsulate an integer value as a 'ParameterValue'@@ -102,14 +129,14 @@ analyze :: Step m () -> State (ScenarioDescription m) () analyze = appendHook "analyze" -appendHook :: String -> Step m () -> State (ScenarioDescription m) ()+appendHook :: Text -> Step m () -> State (ScenarioDescription m) () appendHook name f = modify (addHook name $ Action f) where addHook k v sc0 = sc0 { sHooks = M.insert k v (sHooks sc0) } -- | Returns a 'Result' object for the given name. -- -- Implementations will return their specific results.-result :: Monad m => String -> Step m (Result m)+result :: Monad m => FilePath -> Step m (Result m) result name = do (b,r) <- ask bResult b r name@@ -117,16 +144,16 @@ -- | Write (overwrite) the result in its entirety. -- -- Implementations will return their specific results.-writeResult :: Monad m => String -- ^ result name- -> String -- ^ result content+writeResult :: Monad m => FilePath -- ^ result name+ -> Text -- ^ result content -> Step m () writeResult name dat = result name >>= flip pWrite dat -- | Appends a chunk of data to the result. -- -- Implementations will return their specific results.-appendResult :: Monad m => String -- ^ result name- -> String -- ^ content to add+appendResult :: Monad m => FilePath -- ^ result name+ -> Text -- ^ content to add -> Step m () appendResult name dat = result name >>= flip pAppend dat @@ -135,7 +162,7 @@ logger = ask >>= uncurry bLogger -- | Sends a line of data to the logger (debug mode)-dbg :: Monad m => String -> Step m ()+dbg :: Monad m => Text -> Step m () dbg msg = logger >>= flip lLog msg -- | Interrupts the scenario by throwing an error@@ -144,21 +171,21 @@ -- | Get the parameter with given name. -- Throw an error if the parameter is missing.-param :: Monad m => String -- ^ the parameter name+param :: Monad m => Text -- ^ the parameter name -> Step m ParameterValue param key = do ret <- liftM (M.lookup key . eParamSet . snd) ask- maybe (throwError $ ExecutionError $ "missing param: " ++ key) return ret+ maybe (throwError $ ExecutionError $ "missing param: " ++ unpack key) return ret -getVar' :: (Functor m, MonadState DynEnv m) => String -> m (Maybe Dynamic)+getVar' :: (Functor m, MonadState DynEnv m) => Text -> m (Maybe Dynamic) getVar' k = M.lookup k <$> get -setVar' :: (MonadState DynEnv m) => String -> Dynamic -> m ()+setVar' :: (MonadState DynEnv m) => Text -> Dynamic -> m () setVar' k v = modify (M.insert k v) -- | Set an execution variable. setVar :: (Typeable v, MonadState DynEnv m) =>- String -- ^ name of the variable+ Text -- ^ name of the variable -> v -- ^ value of the variable -> m () setVar k v = setVar' k (toDyn v)@@ -169,7 +196,7 @@ -- Returns 'Nothing' if the variable is missing or if it could not -- be cast to the wanted type. getVar :: (Typeable v, Functor m, MonadState DynEnv m) => - String -- ^ name of the variable+ Text -- ^ name of the variable -> m (Maybe v) getVar k = maybe Nothing fromDynamic <$> getVar' k
Laborantin/Implementation.hs view
@@ -8,10 +8,13 @@ ) where import qualified Data.Map as M+import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as C import Laborantin.Types+import Laborantin.Query import Data.Aeson (decode,encode,FromJSON,parseJSON,(.:),ToJSON,toJSON,(.=),object) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A@@ -27,6 +30,7 @@ import System.Log.Handler (close) import System.Log.Handler.Simple import System.Log.Handler.Log4jXML+import System.Time (ClockTime(TOD),getClockTime) -- | Default monad for 'defaultBackend'. -- EnvIO carries a 'DynEnv' in a state and allows you to perform IO actions.@@ -37,7 +41,7 @@ runEnvIO m = runStateT m M.empty instance ToJSON ParameterValue where- toJSON (StringParam str) = object ["type" .= ("string"::T.Text), "val" .= T.pack str]+ toJSON (StringParam str) = object ["type" .= ("string"::Text), "val" .= str] toJSON (NumberParam n) = object ["type" .= ("num"::T.Text), "val" .= n] toJSON (Array xs) = toJSON xs toJSON (Range _ _ _) = error "should not have to encode ranges but concrete values instead"@@ -45,12 +49,22 @@ 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) = object [ "scenario-name" .= sName sc+ toJSON (Exec sc params path status es tsts) = object [ "scenario-name" .= sName sc , "params" .= params , "path" .= path , "status" .= status+ , "ancestors" .= (map toJSON es)+ , "timestamps" .= tsts ] + where ancestors = map f es+ f x = toJSON (ePath x, sName $ eScenario x) instance FromJSON ParameterValue where parseJSON (A.Object v) = (v .: "type") >>= match@@ -66,11 +80,17 @@ 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" <*> v .: "path" <*>- v .: "status"+ v .: "status" <*>+ v .: "ancestors" <*>+ v .: "timestamps" parseJSON _ = mzero -- | Default backend for the 'EnvIO' monad. This backend uses the filesystem@@ -88,65 +108,113 @@ defaultBackend :: Backend EnvIO defaultBackend = Backend "default EnvIO backend" prepare finalize setup run teardown analyze recover result load log rm where prepare :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO)- prepare sc params = do- uuid <- liftIO (randomIO :: IO UUID)- let rundir = intercalate "/" [sName sc, show uuid]- let exec = Exec sc params rundir Running- handles <- liftIO $ do- createDirectoryIfMissing True rundir- BSL.writeFile (rundir ++ "/execution.json") (encode exec)- updateGlobalLogger (loggerName exec) (setLevel DEBUG)- h1 <- fileHandler (rundir ++ "/execution-log.txt") DEBUG- h2 <- log4jFileHandler (rundir ++ "/execution-log.xml") DEBUG- forM_ [h1,h2] (updateGlobalLogger (loggerName exec) . addHandler)- putStrLn $ advertise exec- return [h1,h2]- return (exec, \_ -> liftIO $ forM_ handles close)+ prepare = prepareNewScenario finalize exec finalizer = do finalizer exec+ now <- liftIO $ getClockTime+ let exec' = updateCompletionTime exec now liftIO . putStrLn $ "execution finished\n"- liftIO $ BSL.writeFile (rundir ++ "/execution.json") (encode exec)+ liftIO $ BSL.writeFile (rundir ++ "/execution.json") (encode exec') where rundir = ePath exec setup = callHooks "setup" . eScenario run = callHooks "run" . eScenario teardown = callHooks "teardown" . eScenario- analyze exec = liftIO (putStrLn $ advertise exec) >> callHooks "analyze" (eScenario exec)+ analyze exec = liftIO (T.putStrLn $ advertise exec) >> callHooks "analyze" (eScenario exec) recover err exec = unAction (doRecover err) where doRecover = fromMaybe (\_ -> Action $ return ()) (sRecoveryAction $ eScenario exec) result exec = return . defaultResult exec+ log exec = return $ defaultLog exec+ rm exec = liftIO $ removeDirectoryRecursive $ ePath exec - load :: ScenarioDescription EnvIO -> EnvIO [Execution EnvIO]- load sc = liftIO $ do- dirs <- filter notDot <$> getDirectoryContents (sName sc)- let paths = map ((sName sc ++ "/") ++) dirs- mapM loadOne paths+ callHooks key sc = maybe (error $ "no such hook: " ++ T.unpack key) unAction (M.lookup key $ sHooks sc)++ load = loadExisting++updateCompletionTime :: Execution m -> ClockTime -> Execution m+updateCompletionTime exec t1 = exec {eTimeStamps = (t0,t1)} + where t0 = fst $ eTimeStamps exec++advertise :: Execution m -> Text+advertise exec = T.pack $ unlines [ "scenario: " ++ (show . sName . eScenario) exec+ , "rundir: " ++ ePath exec+ , "json-params: " ++ (C.unpack . encode . eParamSet) exec+ ]++prepareNewScenario :: ScenarioDescription EnvIO -> ParameterSet -> EnvIO (Execution EnvIO,Finalizer EnvIO)+prepareNewScenario sc params = do+ (now,uuid) <- liftIO $ do+ now <- getClockTime+ id <- randomIO :: IO UUID+ return (now,id)+ let rundir = intercalate "/" [T.unpack (sName sc), show uuid]+ let exec = Exec sc params rundir Running [] (now,now)+ liftIO $ print "resolving dependencies"+ resolveDependencies exec+ handles <- liftIO $ do+ createDirectoryIfMissing True rundir+ BSL.writeFile (rundir ++ "/execution.json") (encode exec)+ updateGlobalLogger (loggerName exec) (setLevel DEBUG)+ h1 <- fileHandler (rundir ++ "/execution-log.txt") DEBUG+ h2 <- log4jFileHandler (rundir ++ "/execution-log.xml") DEBUG+ forM_ [h1,h2] (updateGlobalLogger (loggerName exec) . addHandler)+ T.putStrLn $ advertise exec+ return [h1,h2]+ return (exec, \_ -> liftIO $ forM_ handles close)++resolveDependencies :: Execution EnvIO -> EnvIO ()+resolveDependencies exec = do+ pending <- getPendingDeps exec (sDeps $ eScenario exec)+ resolveDependencies' exec [] pending++resolveDependencies' :: Execution EnvIO -> [Dependency EnvIO] -> [Dependency EnvIO] -> EnvIO ()+resolveDependencies' exec _ [] = return ()+resolveDependencies' exec attempted trying + | all (\d -> elem d attempted) trying = error "cannot solve dependencies"+ | otherwise = do+ mapM (flip dSolve exec) trying+ pending <- getPendingDeps exec trying+ resolveDependencies' exec (trying ++ attempted) pending++getPendingDeps exec deps = map fst . filter (not . snd). zip deps <$> mapM (flip dCheck exec) deps++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)+ allExecs <- mapM (loadOne sc scs) paths+ return $ filter (matchTExpr qexpr) allExecs where notDot dirname = take 1 dirname /= "."- loadOne path = do- exec' <- liftM forStored . decode <$> BSL.readFile (path ++ "/execution.json")- maybe (error $ "decoding: " ++ path) return exec'+ name = T.unpack $ sName sc - where forStored (Stored params path status) = Exec sc params path status- log exec = return $ defaultLog exec- rm exec = liftIO $ removeDirectoryRecursive $ ePath exec+loadOne :: ScenarioDescription EnvIO -> [ScenarioDescription EnvIO] -> FilePath -> EnvIO (Execution EnvIO)+loadOne sc scs path = do+ stored <- decode <$> liftIO (BSL.readFile (path ++ "/execution.json"))+ maybe (error $ "decoding: " ++ path) forStored stored+ where forStored (Stored params path status pairs tsts) = do+ ancestors <- loadAncestors scs pairs+ return $ Exec sc params path status ancestors tsts - callHooks key sc = maybe (error $ "no such hook: " ++ key) unAction (M.lookup key $ sHooks sc)- advertise exec = unlines [ "scenario: " ++ (show . sName . eScenario) exec- , "rundir: " ++ ePath exec- , "json-params: " ++ (C.unpack . encode . eParamSet) exec- ]+loadAncestors :: [ScenarioDescription EnvIO] -> [(FilePath,Text)] -> EnvIO [Execution EnvIO]+loadAncestors scs pairs = catMaybes <$> mapM loadFromPathAndName pairs+ where loadFromPathAndName :: (FilePath,Text) -> EnvIO (Maybe (Execution EnvIO))+ loadFromPathAndName (path, name) = do+ let sc = find ((== name) . sName) scs+ maybe (return Nothing) (\x -> Just <$> loadOne x scs path) sc -- | Default result handler for the 'EnvIO' monad (see 'defaultBackend').-defaultResult :: Execution m -> String -> Result EnvIO-defaultResult exec name = Result path read append write- where read = liftIO $ readFile path- append dat = liftIO $ appendFile path dat- write dat = liftIO $ writeFile path dat- path = intercalate "/" [ePath exec, name]+defaultResult :: Execution m -> FilePath -> Result EnvIO+defaultResult exec basename = Result path read append write+ where read = liftIO $ T.readFile path+ append dat = liftIO $ T.appendFile path dat+ write dat = liftIO $ T.writeFile path dat+ path = intercalate "/" [ePath exec, basename] -- | Default logger for the 'EnvIO' monad (see 'defaultBackend'). defaultLog :: Execution m -> LogHandler EnvIO defaultLog exec = LogHandler logF- where logF msg = liftIO $ debugM (loggerName exec) msg+ where logF txt = liftIO $ debugM (loggerName exec) (T.unpack txt) path = ePath exec ++ "/execution.log" loggerName :: Execution m -> String
+ Laborantin/Query.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Laborantin.Query (matchTExpr, simplifyOneBoolLevel, showTExpr) where++import Laborantin.Types+import qualified Data.Map as M+import Control.Applicative ((<$>),(<*>))+import Data.Text (Text)+import qualified Data.Text as T++type Param = Maybe ParameterValue++data EvalError = EvalError String+ deriving (Show)++simplifyOneBoolLevel :: TExpr Bool -> TExpr Bool+simplifyOneBoolLevel (And (B True) e) = simplifyOneBoolLevel e+simplifyOneBoolLevel (And e (B True)) = simplifyOneBoolLevel e+simplifyOneBoolLevel (And a b) = (And (simplifyOneBoolLevel a) (simplifyOneBoolLevel b))+simplifyOneBoolLevel (Or (B False) e) = simplifyOneBoolLevel e+simplifyOneBoolLevel (Or e (B False)) = simplifyOneBoolLevel e+simplifyOneBoolLevel (Or a b) = (Or (simplifyOneBoolLevel a) (simplifyOneBoolLevel b))+simplifyOneBoolLevel e = e++matchTExpr :: TExpr Bool -> Execution m -> Bool+matchTExpr e q = match' (evalExpr q e)+ where match' (Right True) = True+ match' _ = False++evalExpr :: Execution m -> TExpr a -> Either EvalError a+evalExpr exec (TBind _ f expr) = evalExpr exec expr >>= evalExpr exec . f+evalExpr _ (N x) = Right x+evalExpr _ (B x) = Right x+evalExpr _ (S x) = Right x+evalExpr exec (L xs) = mapM (evalExpr exec) xs >>= Right+evalExpr _ (T x) = Right x+evalExpr exec ScName = Right $ sName $ eScenario exec+evalExpr exec ScStatus | eStatus exec == Success = Right "success"+ | eStatus exec == Failure = Right "failure"+ | eStatus exec == Running = Right "running"+evalExpr exec (ScParam key) = Right $ (key, M.lookup key (eParamSet exec))+evalExpr x (Not e) = not <$> evalExpr x e+evalExpr x (Gt e1 e2) = (>=) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (Eq e1 e2) = (==) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (Plus e1 e2) = (+) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (Times e1 e2) = (*) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (And e1 e2) = (&&) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (Or e1 e2) = (||) <$> evalExpr x e1 <*> evalExpr x e2+evalExpr x (SCoerce e1) = evalExpr x e1 >>= uncurry coerceStringParam+evalExpr x (NCoerce e1) = evalExpr x e1 >>= uncurry coerceNumberParam+evalExpr x (Contains (SilentSCoerce e1) e2) = do+ paramVal <- (evalExpr x e1)+ case paramVal of+ (_, (Just (StringParam str))) -> elem str <$> evalExpr x e2+ _ -> return False+evalExpr x (Contains (SilentNCoerce e1) e2) = do+ paramVal <- (evalExpr x e1)+ case paramVal of+ (_, (Just (NumberParam str))) -> elem str <$> evalExpr x e2+ _ -> return False+evalExpr x (Contains e1 e2) = elem <$> evalExpr x e1 <*> evalExpr x e2+++coerceStringParam :: Text -> Param -> Either EvalError (Text)+coerceStringParam _ (Just (StringParam str)) = Right str+coerceStringParam name _ = Left (EvalError $ "could not coerce "+ ++ T.unpack name+ ++ " to String")++coerceNumberParam :: Text -> Param -> Either EvalError (Rational)+coerceNumberParam name (Just (NumberParam r)) = Right r+coerceNumberParam name _ = Left (EvalError $ "could not coerce "++ T.unpack name ++" to number")++showTExpr :: TExpr a -> String+showTExpr (N x) = show x+showTExpr (B x) = show x+showTExpr (S x) = show x+showTExpr (L x) = show x+showTExpr (T x) = show x+showTExpr (Not x) = "! " ++ "(" ++ showTExpr x ++ ")"+showTExpr (And e1 e2) = "(" ++ showTExpr e1 ++ " && " ++ showTExpr e2 ++ ")"+showTExpr (Or e1 e2) = "(" ++ showTExpr e1 ++ " || " ++ showTExpr e2 ++ ")"+showTExpr (Contains e1 e2) = "(" ++ showTExpr e1 ++ " in " ++ showTExpr e2 ++ ")"+showTExpr (Gt e1 e2) = "(" ++ showTExpr e1 ++ " > " ++ showTExpr e2 ++ ")"+showTExpr (Eq e1 e2) = "(" ++ showTExpr e1 ++ " == " ++ showTExpr e2 ++ ")"+showTExpr (Plus e1 e2) = "(" ++ showTExpr e1 ++ " + " ++ showTExpr e2 ++ ")"+showTExpr (Times e1 e2) = "(" ++ showTExpr e1 ++ " * " ++ showTExpr e2 ++ ")"+showTExpr ScName = "@sc.name"+showTExpr ScStatus = "@sc.status"+showTExpr (ScParam key) = "@sc.param:" ++ show key+showTExpr (SCoerce x) = showTExpr x+showTExpr (NCoerce x) = showTExpr x+showTExpr (SilentSCoerce x) = showTExpr x+showTExpr (SilentNCoerce x) = showTExpr x+showTExpr (TBind str f x) = "(" ++ str ++ " -> (" ++ showTExpr x ++ "))"++instance (Show (TExpr a)) where+ show = showTExpr++showUExpr :: UExpr -> String+showUExpr (UN x) = show x+showUExpr (UB x) = show x+showUExpr (US x) = show x+showUExpr (UL x) = show x+showUExpr (UT x) = show x+showUExpr (UNot x) = "! " ++ "(" ++ showUExpr x ++ ")"+showUExpr (UAnd e1 e2) = "(" ++ showUExpr e1 ++ " and " ++ showUExpr e2 ++ ")"+showUExpr (UOr e1 e2) = "(" ++ showUExpr e1 ++ " or " ++ showUExpr e2 ++ ")"+showUExpr (UContains e1 e2) = "(" ++ showUExpr e1 ++ " in " ++ showUExpr e2 ++ ")"+showUExpr (UGt e1 e2) = "(" ++ showUExpr e1 ++ " > " ++ showUExpr e2 ++ ")"+showUExpr (UGte e1 e2) = "(" ++ showUExpr e1 ++ " >= " ++ showUExpr e2 ++ ")"+showUExpr (ULt e1 e2) = "(" ++ showUExpr e1 ++ " < " ++ showUExpr e2 ++ ")"+showUExpr (ULte e1 e2) = "(" ++ showUExpr e1 ++ " <= " ++ showUExpr e2 ++ ")"+showUExpr (UEq e1 e2) = "(" ++ showUExpr e1 ++ " == " ++ showUExpr e2 ++ ")"+showUExpr (UPlus e1 e2) = "(" ++ showUExpr e1 ++ " + " ++ showUExpr e2 ++ ")"+showUExpr (UMinus e1 e2) = "(" ++ showUExpr e1 ++ " - " ++ showUExpr e2 ++ ")"+showUExpr (UTimes e1 e2) = "(" ++ showUExpr e1 ++ " * " ++ showUExpr e2 ++ ")"+showUExpr (UDiv e1 e2) = "(" ++ showUExpr e1 ++ " / " ++ showUExpr e2 ++ ")"+showUExpr UScName = "@sc.name"+showUExpr UScStatus = "@sc.status"+showUExpr (UScParam key) = "@sc.param:" ++ show key++instance (Show UExpr) where+ show = showUExpr
+ Laborantin/Query/Interpret.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}++module Laborantin.Query.Interpret (toTExpr) where++import Laborantin.Types+import Control.Applicative ((<$>),(<*>))+import Laborantin.Query+import Data.Text (Text)+import Data.Maybe (fromMaybe)+import System.Time (ClockTime)++type Param = Maybe ParameterValue++data TTyp a where+ TTBool :: TTyp Bool+ TTNum :: TTyp Rational+ TTString :: TTyp Text+ TTParam :: TTyp (Text,Param)+ TTClock :: TTyp ClockTime++data IError = IError+ deriving (Show)++-- carries the type of a TExpr+data ATExpr = forall a . TExpr a ::: TTyp a++instance Show ATExpr where+ show (expr ::: ty) = showTExpr expr++toTExpr :: TExpr Bool -> UExpr -> (TExpr Bool)+toTExpr expr = fromMaybe expr . toTExpr'++toTExpr' :: UExpr -> Maybe (TExpr Bool)+toTExpr' u = case interpret u of+ Right (expr ::: TTBool) -> Just expr+ _ -> Nothing+++interpret :: UExpr -> Either IError ATExpr+interpret UScName = Right (ScName ::: TTString)+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 (UN a) = Right (N a ::: TTNum)+interpret (US a) = Right (S a ::: TTString)+interpret (UAnd a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTBool, y ::: TTBool) -> Right (And x y ::: TTBool)+ _ -> error "typing"+interpret (UOr a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTBool, y ::: TTBool) -> Right (Or x y ::: TTBool)+ _ -> error "typing"+interpret (UPlus a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Plus x y ::: TTNum)+ _ -> error "typing"+interpret (UMinus a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Times x (TBind "0 - x" (\n -> N (0 - n)) y) ::: TTNum)+ _ -> error "typing"+interpret (UTimes a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Times x y ::: TTNum)+ _ -> error "typing"+interpret (UDiv a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Times x (TBind "1/x" (\n -> N (1/n)) y) ::: TTNum)+ _ -> error "typing"+interpret (UEq a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Eq x y ::: TTBool)+ (x ::: TTString, y ::: TTString) -> Right (Eq x y ::: TTBool)+ (x ::: TTBool, y ::: TTBool) -> Right (Eq x y ::: TTBool)+ (x ::: TTParam, y ::: TTString) -> Right (Eq (SCoerce x) y ::: TTBool)+ (x ::: TTString, y ::: TTParam) -> Right (Eq x (SCoerce y) ::: TTBool)+ (x ::: TTParam, y ::: TTNum) -> Right (Eq (NCoerce x) y ::: TTBool)+ (x ::: TTNum, y ::: TTParam) -> Right (Eq x (NCoerce y) ::: TTBool)+ (x ::: TTParam, y ::: TTParam) -> Right (Eq x y ::: TTBool)+ _ -> error "typing"+interpret (UGt a b) = do+ vals <- ((,) <$> interpret a <*> interpret b)+ case vals of+ (x ::: TTNum, y ::: TTNum) -> Right (Gt x y ::: TTBool)+ (x ::: TTParam, y ::: TTNum) -> Right (Gt (NCoerce x) y ::: TTBool)+ (x ::: TTNum, y ::: TTParam) -> Right (Gt x (NCoerce y) ::: TTBool)+ (x ::: TTParam, y ::: TTParam) -> Right (Gt (NCoerce x) (NCoerce y) ::: TTBool)+ _ -> error "typing error"+interpret (UGte a b) = interpret (UOr (UGt a b) (UEq a b))+interpret (ULt a b) = interpret (UNot (UGte a b))+interpret (ULte a b) = interpret (UNot (UGt a b))+interpret (UContains a b) = do+ val <- interpret a+ case val of+ (x ::: TTNum) -> Right (Contains x (L $ ttnums b) ::: TTBool)+ (x ::: TTString) -> Right (Contains x (L $ ttstrs b) ::: TTBool)+ (x ::: TTParam) -> Right ((Or (Contains (SilentSCoerce x) (L $ ttstrs b))+ (Contains (SilentNCoerce x) (L $ ttnums b)))+ ::: TTBool)+ _ -> error "interpretation unsupported"+interpret (UL as) = do+ -- TODO evaluate non-heterogeneous lists+ error "cannot safely evaluate list which may be heterogeneous"+interpret (UNot x) = do+ val <- interpret x+ case val of+ (x ::: TTBool) -> Right (Not x ::: TTBool)+ _ -> error "typing error"++ttnums :: UExpr -> [TExpr Rational]+ttnums (UL xs) = map (\(UN x) -> N x) (filter match xs)+ where match (UN _) = True+ match _ = False+ttnums _ = []++ttstrs :: UExpr -> [TExpr Text]+ttstrs (UL xs) = map (\(US x) -> S x) (filter match xs)+ where match (US _) = True+ match _ = False+ttstrs _ = []
+ Laborantin/Query/Parse.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TupleSections #-}++module Laborantin.Query.Parse (expr, parseUExpr) where++import Laborantin.Types (UExpr (..))+import Control.Applicative ((<$>),(<*>),(*>),(<*))+import qualified Data.Text as T+import Text.Parsec+import Text.Parsec.Char+import Text.Parsec.Combinator+import Data.Maybe (fromJust)++parseUExpr :: String -> Either ParseError UExpr+parseUExpr = parse expr ""++expr :: Parsec String u 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 = UNot <$> (spaces *> char '!' *> spaces *> expr)+++ary :: Parsec String u UExpr+ary = UL <$> (char '[' *> (expr `sepBy` (spaces >> char ',' >> spaces)) <* char ']')+ +binOp xs = do+ spaces+ val <- foldl1 (<|>) (map (try . string . fst) xs)+ spaces+ return $ fromJust (lookup val xs)++addOp = binOp [("+",UPlus),("-",UMinus)]+mulOp = binOp [("*",UTimes),("/",UDiv)]+boolOp = binOp [("and",UAnd),("or",UOr)]+compOp = binOp [(">=",UGte),(">",UGt),("==",UEq),("<=",ULte),("<",ULt)]+inclOp = binOp [("in",UContains), ("~>",UContains)]++literal :: Parsec String u UExpr+literal = bool <|> (UN <$> number) <|> (US . T.pack <$> quotedString)++special :: Parsec String u UExpr+special = try scname <|> try scstatus <|> scparam++scname,scstatus,scparam :: Parsec String u UExpr+scname = string "@sc.name" *> return UScName+scstatus = string "@sc.status" *> return UScStatus+scparam = UScParam . T.pack <$> (syntax1 <|> syntax2)+ where syntax1 = string "@sc.param" *> spaces *> quotedString+ syntax2 = char ':' *> plainString++quotedString :: Parsec String u String+quotedString = char '"' *> many (noneOf "\"") <* char '"'++plainString :: Parsec String u String+plainString = many (noneOf " ")++number :: Parsec String u (Rational)+number = do+ (dec,frac) <- (try decFrac) <|> (try dec)+ return $ read (dec ++ frac ++ " % 1" ++ (map snd $ zip frac (repeat '0')))++dec,decFrac :: Parsec String u (String,String)+dec = (,"") <$> many1 digit+decFrac = do a <- many1 digit+ char '.'+ b <- many1 digit+ return (a,b)++bool :: Parsec String u UExpr+bool = true <|> false <|> fail "bool"+ where true = string "true" >> return (UB True) + false = string "false" >> return (UB False)
Laborantin/Types.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-} module Laborantin.Types ( ScenarioDescription (..)@@ -21,15 +24,21 @@ , Step , Action (..) , DynEnv (..)+ , TExpr (..)+ , UExpr (..)+ , Dependency (..) ) where import qualified Data.Map as M+import System.Time (ClockTime) import Control.Monad.Reader import Control.Monad.Error import Data.Dynamic+import Data.Text (Text)+import qualified Data.Text as T -type DynEnv = M.Map String Dynamic-type ParameterSpace = M.Map String ParameterDescription+type DynEnv = M.Map Text Dynamic+type ParameterSpace = M.Map Text ParameterDescription data ExecutionError = ExecutionError String deriving (Show) data AnalysisError = AnalysisError String@@ -51,26 +60,27 @@ show _ = "(Error-recovery action)" data ScenarioDescription m = SDesc {- sName :: String- , sDesc :: String+ sName :: Text+ , sDesc :: Text , sParams :: ParameterSpace- , sHooks :: M.Map String (Action m)+ , sHooks :: M.Map Text (Action m) , sRecoveryAction :: Maybe (ExecutionError -> Action m)+ , sDeps :: [Dependency m] } deriving (Show) data ParameterDescription = PDesc {- pName :: String- , pDesc :: String+ pName :: Text+ , pDesc :: Text , pValues :: [ParameterValue] } deriving (Show,Eq,Ord) -data ParameterValue = StringParam String +data ParameterValue = StringParam Text | NumberParam Rational | Array [ParameterValue] | Range Rational Rational Rational -- [from, to], by increment deriving (Show,Eq,Ord) -type ParameterSet = M.Map String ParameterValue+type ParameterSet = M.Map Text ParameterValue data ExecutionStatus = Running | Success | Failure deriving (Show,Read,Eq)@@ -78,16 +88,37 @@ data Execution m = Exec { eScenario :: ScenarioDescription m , eParamSet :: ParameterSet- , ePath :: String+ , ePath :: FilePath , eStatus :: ExecutionStatus+ , eAncestors :: [Execution m] + , eTimeStamps :: (ClockTime,ClockTime) } deriving (Show) data StoredExecution = Stored { seParamSet :: ParameterSet- , sePath :: String+ , sePath :: FilePath , seStatus :: ExecutionStatus+ , seAncestors :: [(FilePath,Text)]+ , seTimeStamps :: (ClockTime,ClockTime) } deriving (Show) +data Dependency m = Dep {+ dName :: Text+ , dDesc :: Text+ , dCheck :: Execution m -> m Bool+ , dSolve :: Execution m -> m ()+ }++instance Eq (Dependency m) where+ d1 == d2 = dName d1 == dName d2 && dDesc d1 == dDesc d2++instance Show (Dependency m) where+ show dep = "Dep {dName="+ ++ show (dName dep)+ ++ ", dDesc="+ ++ show (dDesc dep)+ ++ "}" + expandValue :: ParameterValue -> [ParameterValue] expandValue (Range from to by) = map NumberParam [from,from+by .. to] expandValue x = [x]@@ -99,7 +130,7 @@ type Finalizer m = Execution m -> m () data Backend m = Backend {- bName :: String+ bName :: Text , bPrepareExecution :: ScenarioDescription m -> ParameterSet -> m (Execution m,Finalizer m) , bFinalizeExecution :: Execution m -> Finalizer m -> m () , bSetup :: Execution m -> Step m ()@@ -107,17 +138,62 @@ , bTeardown :: Execution m -> Step m () , bAnalyze :: Execution m -> Step m () , bRecover :: ExecutionError -> Execution m -> Step m ()- , bResult :: Execution m -> String -> Step m (Result m)- , bLoad :: ScenarioDescription m -> m [Execution m]+ , bResult :: Execution m -> FilePath -> Step m (Result m)+ , bLoad :: [ScenarioDescription m] -> TExpr Bool -> m [Execution m] , bLogger :: Execution m -> Step m (LogHandler m) , bRemove :: Execution m -> m () } data Result m = Result {- pPath :: String- , pRead :: Step m String- , pAppend :: String -> Step m ()- , pWrite :: String -> Step m ()+ pPath :: FilePath+ , pRead :: Step m Text+ , pAppend :: Text -> Step m ()+ , pWrite :: Text -> Step m () } -newtype LogHandler m = LogHandler { lLog :: String -> Step m () }+newtype LogHandler m = LogHandler { lLog :: Text -> Step m () }++data TExpr :: * -> * where+ N :: Rational -> TExpr Rational+ B :: Bool -> TExpr Bool+ S :: Text -> TExpr Text+ L :: [TExpr a] -> TExpr [a]+ T :: ClockTime -> TExpr ClockTime+ Plus :: TExpr Rational -> TExpr Rational -> TExpr Rational+ Times :: TExpr Rational -> TExpr Rational -> TExpr Rational+ And :: TExpr Bool -> TExpr Bool -> TExpr Bool+ Or :: TExpr Bool -> TExpr Bool -> TExpr Bool+ Not :: TExpr Bool -> TExpr Bool+ Contains :: (Show a, Eq a) => TExpr a -> TExpr [a] -> TExpr Bool+ Eq :: (Show a, Eq a) => TExpr a -> TExpr a -> TExpr Bool+ Gt :: (Show a, Ord a) => TExpr a -> TExpr a -> TExpr Bool+ ScName :: TExpr Text+ ScStatus :: TExpr Text+ ScParam :: Text -> TExpr (Text, Maybe ParameterValue)+ SCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Text+ NCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Rational+ SilentSCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Text+ SilentNCoerce :: TExpr (Text, Maybe ParameterValue) -> TExpr Rational+ TBind :: String -> (a -> TExpr b) -> TExpr a -> TExpr b++data UExpr = UN Rational+ | UB Bool+ | US Text+ | UL [UExpr]+ | UT ClockTime+ | UPlus UExpr UExpr+ | UMinus UExpr UExpr+ | UTimes UExpr UExpr+ | UDiv UExpr UExpr+ | UAnd UExpr UExpr+ | UOr UExpr UExpr+ | UContains UExpr UExpr+ | UEq UExpr UExpr+ | UGt UExpr UExpr+ | UGte UExpr UExpr+ | ULte UExpr UExpr+ | ULt UExpr UExpr+ | UNot UExpr+ | UScName+ | UScStatus+ | UScParam Text
README.md view
@@ -112,14 +112,15 @@ # Roadmap --# TODO+For version 1. -* save timing of scenario executions in default backend-* standalone query expression module-* use Text rather than String where appropriate-* dependency type with annotations to execute missing dependencies-* dumb dependency solver-* selector to load prior results-* "require" helper that sets a dep+selection+* Parse clocktime+* Debug errors in+* Function to expand TExpr to parameter space (for run command)+* Selector to load prior results based on a TExpr+ - "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+
+ examples/main.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where+ +import Laborantin+import Laborantin.Types+import Laborantin.DSL+import Laborantin.Implementation+import Laborantin.CLI+import Laborantin.Query+import Control.Monad.IO.Class+import qualified Data.Text as T++{- + - Example+ -}++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", str "nonexistent"]+ parameter "packet-size" $ do+ describe "packet size in bytes"+ values [num 50, num 1500] + parameter "burst-length" $ do+ describe "number of back-to-back packets to send"+ values [range 1 100 10] + dependency "dummy" $ do+ describe "always true"+ check (\exec -> return True)+ resolve (\exec -> liftIO (print "resolving"))+ setup $ do+ setVar "hello" ("world"::String)+ dbg "setting up scenario"+ run $ do+ (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+ 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)+ analyze $ liftIO . print $ "analyze action"++main = defaultMain [ping]
laborantin-hs.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: laborantin-hs-version: 0.1.1.2+version: 0.1.1.3 synopsis: an experiment management framework -- description: homepage: https://github.com/lucasdicioccio/laborantin-hs@@ -17,9 +17,16 @@ cabal-version: >=1.10 library- exposed-modules: Laborantin, Laborantin.DSL, Laborantin.Implementation, Laborantin.Types, Laborantin.CLI- -- other-modules: + 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+ 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 -- hs-source-dirs: + default-language: Haskell2010++executable labor-example+ main-is: main.hs+ ghc-options: -Wall+ hs-source-dirs: examples+ 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, laborantin-hs >= 0.1.1.2 default-language: Haskell2010