module Laborantin.DSL (
scenario
, describe
, parameter
, require
, requireTExpr
, dependency
, check
, resolve
, values
, str
, num
, range
, arr
, setup
, teardown
, run
, self
, backend
, param
, ancestors
, ancestorsMatching
, ancestorsMatchingTExpr
, getVar
, setVar
, recover
, analyze
, result
, writeResult
, appendResult
, logger
, dbg
, err
) where
import qualified Data.Map as M
import Data.List (partition, nubBy)
import Laborantin
import Laborantin.Types
import Laborantin.Query
import Laborantin.Query.Parse
import Laborantin.Query.Interpret
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Error
import Control.Applicative
import Data.Dynamic
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
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 :: (Monad m) => Text -> State (ScenarioDescription m) () -> ScenarioDescription m
scenario name f = execState f sc0
where sc0 = emptyScenario { sName = name, sHooks = defaultNoHooks}
where defaultNoHooks = M.fromList [ ("setup", noop)
, ("teardown", noop)
, ("run", noop)
, ("analyze", noop)
]
noop = Action (return ())
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 "" checkF solveF
checkF = const (return True)
solveF = return . fst
check :: (Execution m -> m Bool) -> State (Dependency m) ()
check f = do
dep0 <- get
put $ dep0 { dCheck = f }
resolve :: ((Execution m, Backend m) -> m (Execution 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) }
requireTExpr :: (MonadIO m, Monad m) => ScenarioDescription m -> TExpr Bool -> State (ScenarioDescription m) ()
requireTExpr sc query = do
let depName = T.concat [(sName sc), " ~> ", (pack $ show query)]
modify (\sc0 -> sc0 {sQuery = query})
dependency depName $ do
describe "auto-generated dependency for `require` statement"
check $ \exec -> do
let ancestors = filter ((sName sc ==) . sName . eScenario) (eAncestors exec)
let existing = map eParamSet ancestors
let missing = missingParameterSets sc query existing
return (null $ missing)
resolve $ \(exec,backend) -> do
storedAncestors <- load backend [sc] query
let (execAncestors, otherAncestors) = partition ((sName sc ==) . sName . eScenario) (eAncestors exec)
let allAncestors = nubBy (samePath) (storedAncestors ++ execAncestors)
newAncestors <- sequence $ prepare backend query allAncestors sc
return (exec { eAncestors = newAncestors ++ allAncestors })
where samePath e1 e2 = ePath e1 == ePath e2
require :: (MonadIO m, Monad m) => ScenarioDescription m -> Text -> State (ScenarioDescription m) ()
require sc txt = requireTExpr sc query
where query = either (const deflt) (toTExpr deflt) (parseUExpr defaultParsePrefs (unpack txt))
deflt = (B True)
self :: Monad m => Step m (Execution m)
self = liftM snd ask
backend :: Monad m => Step m (Backend m)
backend = liftM fst ask
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
ancestorsMatchingTExpr :: (Monad m) => Text -> TExpr Bool -> Step m [Execution m]
ancestorsMatchingTExpr name query = liftM (matching . eAncestors . snd) ask
where matching = filter (matchTExpr query)
ancestorsMatching :: (Monad m) => Text -> Text -> Step m [Execution m]
ancestorsMatching name txt = ancestorsMatchingTExpr name query
where query = either (const deflt) (toTExpr deflt) (parseUExpr defaultParsePrefs (unpack txt))
deflt = (B False)
ancestors :: (Monad m) => Text -> Step m [Execution m]
ancestors = flip ancestorsMatchingTExpr (B True)