diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser.hs | 6 | ||||
| -rw-r--r-- | src/Run.hs | 24 | ||||
| -rw-r--r-- | src/Script/Var.hs | 12 | ||||
| -rw-r--r-- | src/Test.hs | 3 | ||||
| -rw-r--r-- | src/TestMode.hs | 2 |
5 files changed, 30 insertions, 17 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 @@ -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" |