summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Parser.hs6
-rw-r--r--src/Run.hs24
-rw-r--r--src/Script/Var.hs12
-rw-r--r--src/Test.hs3
-rw-r--r--src/TestMode.hs2
-rw-r--r--test/script/definition.et2
6 files changed, 31 insertions, 18 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index c94e1e8..928dd88 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -44,8 +44,10 @@ parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do
{ testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar
}
href <- L.indentLevel
- testName <- header
- testModuleName <- gets testCurrentModuleName
+ testNameBase <- header
+ testNameModule <- gets testCurrentModuleName
+ let testName = TestName {..}
+
osymbol ":" <* eol <* scn
ref <- L.indentGuard scn GT href
diff --git a/src/Run.hs b/src/Run.hs
index 579fa20..a646342 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -73,7 +73,7 @@ runTests out opts gdefs tests = do
runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool
runTest out opts gdefs test = do
- let testDir = optTestDir opts </> T.unpack (textModuleName (testModuleName test) <> "." <> testName test)
+ let testDir = optTestDir opts </> T.unpack (textTestName $ testName test)
when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e ->
if isDoesNotExistError e then return () else ioError e
exists <- doesPathExist testDir
@@ -133,7 +133,7 @@ runTest out opts gdefs test = do
testRunResult <- newEmptyMVar
flip runReaderT out $ do
- void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> testName test <> "’"
+ void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> textTestName (testName test) <> "’"
void $ forkOS $ do
isolateFilesystem testDir >>= \case
@@ -142,7 +142,7 @@ runTest out opts gdefs test = do
withInternet $ \_ -> do
runStep =<< eval (testSteps test)
when (optWait opts) $ do
- void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..."
+ void $ outPromptGetLine $ "Test ‘" <> textTestName (testName test) <> "’ completed, waiting..."
putMVar testRunResult tres
_ -> do
putMVar testRunResult ( Left Failed, [] )
@@ -162,13 +162,13 @@ runTest out opts gdefs test = do
return True
_ -> do
flip runReaderT out $ do
- void $ outLine OutputGlobalError Nothing $ "Test ‘" <> testName test <> "’ failed."
+ void $ outLine OutputGlobalError Nothing $ "Test ‘" <> textTestName (testName test) <> "’ failed."
return False
data LoadedModules = LoadedModules
{ lmModules :: [ Module ]
- , lmTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ]
+ , lmTags :: [ ( TestName, [ Tag ] ) ]
, lmGlobalDefs :: GlobalDefs
}
@@ -180,7 +180,7 @@ loadModules files = do
tests <- case tsel of
Nothing -> return $ moduleTests m
Just tname
- | Just test <- find ((tname ==) . testName) (moduleTests m)
+ | Just test <- find ((tname ==) . testNameBase . testName) (moduleTests m)
-> return [ test ]
| otherwise
-> throwError $ TestNotFound tname (Just path)
@@ -188,7 +188,7 @@ loadModules files = do
let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test
- lmTags = concatMap (\Module {..} -> map (\test -> ( ( moduleName, testName test ), evalTags test )) moduleTests) lmModules
+ lmTags = concatMap (\Module {..} -> map (\test -> ( testName test, evalTags test )) moduleTests) lmModules
Right $ LoadedModules {..}
Left err -> do
return $ Left err
@@ -219,7 +219,7 @@ testFilterFromConfig Config {..} = TestFilter
filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ]
filterTests TestFilter {..} LoadedModules {..} = do
- let allTests = concatMap (\m -> ( moduleName m, ) <$> moduleTests m) lmModules
+ let allTests = concatMap moduleTests lmModules
let evalTerm :: Text -> Either CustomTestError (Either Text Tag)
evalTerm t =
case find ((VarName t ==) . snd . fst) $ M.toList lmGlobalDefs of
@@ -227,14 +227,14 @@ filterTests TestFilter {..} LoadedModules {..} = do
| Just (Refl :: etype :~: Tag) <- eqT
-> return $ Right $ runSimpleEval (eval expr) lmGlobalDefs []
Nothing
- | Just _ <- find ((t ==) . testName . snd) allTests
+ | Just _ <- find ((t ==) . testNameBase . testName) allTests
-> return $ Left t
_ ->
throwError $ TestOrTagNotFound t Nothing
exclude <- partitionEithers <$> mapM evalTerm tfExclude
- let matches ( tnames, tags ) ( mname, test ) =
- testName test `elem` tnames || maybe False (any (`elem` tags)) (lookup ( mname, testName test ) lmTags)
- map snd . filter (not . matches exclude) <$> case tfSelect of
+ let matches ( tnames, tags ) test =
+ testNameBase (testName test) `elem` tnames || maybe False (any (`elem` tags)) (lookup (testName test) lmTags)
+ filter (not . matches exclude) <$> case tfSelect of
Nothing -> return allTests
Just tnames -> do
selected <- partitionEithers <$> mapM evalTerm tnames
diff --git a/src/Script/Var.hs b/src/Script/Var.hs
index 2c50101..a3620f4 100644
--- a/src/Script/Var.hs
+++ b/src/Script/Var.hs
@@ -3,6 +3,7 @@ module Script.Var (
FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName,
TypedVarName(..),
ModuleName(..), textModuleName,
+ TestName(..), textTestName,
SourceLine(..), textSourceLine,
) where
@@ -53,6 +54,17 @@ newtype ModuleName = ModuleName [ Text ]
textModuleName :: ModuleName -> Text
textModuleName (ModuleName parts) = T.intercalate "." parts
+
+data TestName = TestName
+ { testNameModule :: ModuleName
+ , testNameBase :: Text
+ }
+ deriving (Eq, Ord)
+
+textTestName :: TestName -> Text
+textTestName (TestName (ModuleName mparts) base) = T.intercalate "." (mparts ++ [ base ])
+
+
data SourceLine
= SourceLine Text
| SourceLineBuiltin
diff --git a/src/Test.hs b/src/Test.hs
index e9aaaba..33c1cf0 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -25,8 +25,7 @@ import Script.Object
import Script.Shell
data Test = Test
- { testName :: Text
- , testModuleName :: ModuleName
+ { testName :: TestName
, testTags :: [ Expr Tag ]
, testSteps :: Expr (TestStep ())
}
diff --git a/src/TestMode.hs b/src/TestMode.hs
index 22d8237..4d8c767 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -163,5 +163,5 @@ cmdRun = do
Right tests -> do
forM_ tests $ \test -> do
res <- runSingleTest test
- cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")
+ cmdOut $ "run-test-result " <> testNameBase (testName test) <> " " <> (if res then "done" else "failed")
cmdOut "run-done"
diff --git a/test/script/definition.et b/test/script/definition.et
index 45951cd..5490349 100644
--- a/test/script/definition.et
+++ b/test/script/definition.et
@@ -10,7 +10,7 @@ test Definition:
expect /load-done/
send "run Test"
- expect /global-info - Starting test ‘Test’/
+ expect /global-info - Starting test ‘basic\.Test’/
expect /child-stdout p 4/
expect /match p 4/
expect /child-stdout p 11/
generated by cgit v1.2.3 (git 2.25.1) at 2026-08-26 06:10:31 +0000