diff --git a/Laborantin.hs b/Laborantin.hs --- a/Laborantin.hs +++ b/Laborantin.hs @@ -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 () diff --git a/Laborantin/CLI.hs b/Laborantin/CLI.hs --- a/Laborantin/CLI.hs +++ b/Laborantin/CLI.hs @@ -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 - diff --git a/Laborantin/DSL.hs b/Laborantin/DSL.hs --- a/Laborantin/DSL.hs +++ b/Laborantin/DSL.hs @@ -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 diff --git a/Laborantin/Implementation.hs b/Laborantin/Implementation.hs --- a/Laborantin/Implementation.hs +++ b/Laborantin/Implementation.hs @@ -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 diff --git a/Laborantin/Query.hs b/Laborantin/Query.hs new file mode 100644 --- /dev/null +++ b/Laborantin/Query.hs @@ -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 diff --git a/Laborantin/Query/Interpret.hs b/Laborantin/Query/Interpret.hs new file mode 100644 --- /dev/null +++ b/Laborantin/Query/Interpret.hs @@ -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 _ = [] diff --git a/Laborantin/Query/Parse.hs b/Laborantin/Query/Parse.hs new file mode 100644 --- /dev/null +++ b/Laborantin/Query/Parse.hs @@ -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) diff --git a/Laborantin/Types.hs b/Laborantin/Types.hs --- a/Laborantin/Types.hs +++ b/Laborantin/Types.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 + diff --git a/examples/main.hs b/examples/main.hs new file mode 100644 --- /dev/null +++ b/examples/main.hs @@ -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] 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.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