summaryrefslogtreecommitdiff
path: root/src/Test.hs
blob: d652f9ba0d28c3c1f7f4cd642cbfe0c5e678ed01 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
module Test (
    Test(..),
    TestStep(..),

    ProcName(..), textProcName, unpackProcName,
    NodeName(..), textNodeName, unpackNodeName,

    MonadEval(..),
    VarName(..), unpackVarName,
    StringExpr(..), evalStringExpr,
    RegexExpr(..), evalRegexExpr,
) where

import Control.Monad

import Data.List
import Data.Text (Text)
import qualified Data.Text as T

import Text.Regex.TDFA
import Text.Regex.TDFA.String

import Process

data Test = Test
    { testName :: Text
    , testSteps :: [TestStep]
    }

data TestStep = Spawn ProcName NodeName
              | Send ProcName StringExpr
              | Expect ProcName RegexExpr
              | Wait

newtype NodeName = NodeName Text
    deriving (Eq, Ord)

textNodeName :: NodeName -> Text
textNodeName (NodeName name) = name

unpackNodeName :: NodeName -> String
unpackNodeName (NodeName tname) = T.unpack tname


class Monad m => MonadEval m where
  lookupStringVar :: VarName -> m Text


data VarName = VarName [Text]
    deriving (Eq, Ord)

unpackVarName :: VarName -> String
unpackVarName (VarName name) = concat $ intersperse "." $ map T.unpack name

data StringExpr = StringExpr [Either Text VarName]

evalStringExpr :: MonadEval m => StringExpr -> m Text
evalStringExpr (StringExpr xs) = fmap T.concat $ forM xs $ \case
    Left text -> return text
    Right var -> lookupStringVar var

data RegexExpr = RegexExpr [Either String VarName]

evalRegexExpr :: (MonadFail m, MonadEval m) => RegexExpr -> m Regex
evalRegexExpr (RegexExpr xs) = do
    parts <- forM xs $ \case
        Left str -> return str
        Right var -> concatMap (\c -> ['\\',c]) . T.unpack <$> lookupStringVar var
    case compile defaultCompOpt defaultExecOpt $ concat $ concat [["^"], parts, ["$"]] of
        Left err -> fail err
        Right re -> return re