module Laborantin.DSL (
scenario
, describe
, parameter
, dependency
, check
, resolve
, values
, str
, num
, range
, arr
, setup
, teardown
, run
, param
, getVar
, setVar
, recover
, analyze
, result
, writeResult
, appendResult
, logger
, dbg
, err
) where
import qualified Data.Map as M
import Laborantin.Types
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Error
import Control.Applicative
import Data.Dynamic
import Data.Text (Text, unpack)
class Describable a where
changeDescription :: Text -> a -> a
instance Describable (ScenarioDescription a) where
changeDescription d sc = sc { sDesc = d }
instance Describable ParameterDescription where
changeDescription d pa = pa { pDesc = d }
instance Describable (Dependency a) where
changeDescription d dep = dep { dDesc = d }
scenario :: Text -> State (ScenarioDescription m) () -> ScenarioDescription m
scenario name f = execState f sc0
where sc0 = SDesc name "" M.empty M.empty Nothing []
describe :: Describable a => Text -> State a ()
describe desc = modify (changeDescription desc)
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 "" []
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 ()))
check :: (Execution m -> m Bool) -> State (Dependency m) ()
check f = do
dep0 <- get
put $ dep0 { dCheck = f }
resolve :: (Execution m -> m ()) -> State (Dependency m) ()
resolve f = do
dep0 <- get
put $ dep0 { dSolve = f }
values :: [ParameterValue] -> State ParameterDescription ()
values xs = do
param0 <- get
put $ param0 { pValues = xs }
str :: Text -> ParameterValue
str = StringParam
num :: Integer -> ParameterValue
num = NumberParam . fromInteger
range :: Rational -> Rational -> Rational -> ParameterValue
range = Range
arr :: [ParameterValue] -> ParameterValue
arr = Array
setup :: Step m () -> State (ScenarioDescription m) ()
setup = appendHook "setup"
run :: Step m () -> State (ScenarioDescription m) ()
run = appendHook "run"
teardown :: Step m () -> State (ScenarioDescription m) ()
teardown = appendHook "teardown"
recover :: (ExecutionError -> Step m ()) -> State (ScenarioDescription m) ()
recover f = modify (setRecoveryAction action)
where action err = Action (f err)
setRecoveryAction act sc = sc {sRecoveryAction = Just act }
analyze :: Step m () -> State (ScenarioDescription m) ()
analyze = appendHook "analyze"
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) }
result :: Monad m => FilePath -> Step m (Result m)
result name = do
(b,r) <- ask
bResult b r name
writeResult :: Monad m => FilePath
-> Text
-> Step m ()
writeResult name dat = result name >>= flip pWrite dat
appendResult :: Monad m => FilePath
-> Text
-> Step m ()
appendResult name dat = result name >>= flip pAppend dat
logger :: Monad m => Step m (LogHandler m)
logger = ask >>= uncurry bLogger
dbg :: Monad m => Text -> Step m ()
dbg msg = logger >>= flip lLog msg
err :: Monad m => String -> Step m ()
err = throwError . ExecutionError
param :: Monad m => Text
-> Step m ParameterValue
param key = do
ret <- liftM (M.lookup key . eParamSet . snd) ask
maybe (throwError $ ExecutionError $ "missing param: " ++ unpack key) return ret
getVar' :: (Functor m, MonadState DynEnv m) => Text -> m (Maybe Dynamic)
getVar' k = M.lookup k <$> get
setVar' :: (MonadState DynEnv m) => Text -> Dynamic -> m ()
setVar' k v = modify (M.insert k v)
setVar :: (Typeable v, MonadState DynEnv m) =>
Text
-> v
-> m ()
setVar k v = setVar' k (toDyn v)
getVar :: (Typeable v, Functor m, MonadState DynEnv m) =>
Text
-> m (Maybe v)
getVar k = maybe Nothing fromDynamic <$> getVar' k