erebos-tester 0.3.5 → 0.3.6
raw patch · 26 files changed
+1050/−228 lines, 26 files
Files
- CHANGELOG.md +16/−0
- README.md +51/−21
- erebos-tester.cabal +10/−2
- src/Asset.hs +3/−3
- src/JUnit.hs +60/−0
- src/Main.hs +48/−8
- src/Network.hs +5/−4
- src/Output.hs +86/−27
- src/Parser.hs +32/−19
- src/Parser/Core.hs +45/−24
- src/Parser/Expr.hs +47/−8
- src/Parser/Shell.hs +51/−14
- src/Parser/Statement.hs +4/−1
- src/Process.hs +1/−1
- src/Run.hs +127/−37
- src/Run/Builtins.hs +43/−0
- src/Run/Monad.hs +7/−0
- src/Script/Expr.hs +4/−1
- src/Script/Expr/Class.hs +7/−7
- src/Script/Shell.hs +150/−41
- src/Script/Var.hs +12/−0
- src/Test.hs +5/−1
- src/TestMode.hs +16/−9
- src/TextFormat.hs +79/−0
- src/TextFormat/Ansi.hs +83/−0
- src/TextFormat/Types.hs +58/−0
CHANGELOG.md view
@@ -1,5 +1,21 @@ # Revision history for erebos-tester +## 0.3.6 -- 2026-09-08++* Added reporting-related command-line options:+ * `--keep-going` to continue after test failure,+ * `--report` to print summary of passed/failed tests,+ * `--junit-report` to generate test report in JUnit XML format.+* Explicit type annotation can now be added to expressions and to arguments in function definition using the `:` notation.+* Test dir subdirectory that includes the test module and name is now created for each test.+* Tests can now be selected (or excluded) using module names and fully-qualified names of Tests and Tags.+* In the built-in shell interpreter is now implemented:+ * working directory handling with `pwd` and `cd` commands,+ * `set +e`/`-e` command to change fail-on-error behavior,+ * negation using the `!` operator,+ * dollar-expansion for lists to provide list of shell command arguments.+* Fixed parsing of disconnect and packet-loss commands.+ ## 0.3.5 -- 2026-05-31 * Added tags to group and filter tests.
README.md view
@@ -31,17 +31,15 @@ ----- The `erebos-tester` tool, when executed without any arguments,-looks for a `erebos-tester.yaml` file in the current or any parent directory (see below for details).-Run `erebos-tester --help` for details about command-line parameters.+looks for an `erebos-tester.yaml` file in the current or any parent directory (see below for details).+Run `erebos-tester --help` for details about available command-line parameters. -The tester can be installed from sources or directly via cabal:-```-cabal install erebos-tester-```+### Examples -When available in the `PATH`, it can be run to test the [Haskell Erebos implementation](https://erebosprotocol.net/erebos):+When available in the `PATH`, it can be run, for example, to test+the [Haskell Erebos implementation](https://erebosprotocol.net/erebos): ```-git clone git://erebosprotocol.net/erebos+git clone https://code.erebosprotocol.net/erebos cd erebos cabal build erebos-tester --tool="$(cabal list-bin erebos) test" --verbose@@ -49,13 +47,15 @@ or the [C++ one](https://erebosprotocol.net/cpp): ```-git clone git://erebosprotocol.net/cpp+git clone https://code.erebosprotocol.net/cpp cd cpp cmake -B build cmake --build build erebos-tester --verbose ``` +### Running+ To run all tests from project configuration (see below), run the tester without any argument: ``` erebos-tester@@ -78,6 +78,20 @@ erebos-tester path/to/script.et:TestName ``` +### Reports++By default, `erebos-tester` stops when a test fails, showing backtrace and+values of used variables. That can be changed with the following command-line+options:++* `--report`: run all the tests, continuing even in the case of error, and+ print a short summary of the number of passed and failed test, and a list of+ those that failed.++* `--junit-report=<path>`: run all the tests, and write the report to the file+ in `<path>` using the JUnit XML format.++ Configuration ------------- @@ -123,8 +137,15 @@ although types can not be (as of now) declared explicitly and are always inferred. Each expression has specific concrete type, polymorphic types are not supported (yet). -#### integer+Generally, types of expressions should be inferred, but they can also be given+explicitly to any (sub)expression using the `:` notation:+```+let x = 1 : Integer+let y = (2 : Integer) + (x : Integer)+``` +#### `Integer`+ Integer numbers. Entered as decimal literals and used in arithmetic expressions: ``` let x = 2@@ -132,7 +153,7 @@ let z = x * 2 + y ``` -#### number+#### `Number` Arbitrary-precision numbers. Entered as literals with decimal point or percentage and used in arithmetic expressions: ```@@ -141,7 +162,7 @@ let z = x * 2.0 + y ``` -#### string+#### `String` String literals are enclosed in double quotes (`"`), using backslash to escape special characters (`"`, `\` and `$`)@@ -164,7 +185,7 @@ let s = "abc ${2*a + b}" # = "abc 7" ``` -#### regex+#### `Regex` Regular expression literals are enclosed in slash characters (`/`): ```@@ -180,16 +201,16 @@ let re2 = /$str$re1/ # match '.' followed by any character ``` -#### boolean+#### `Bool` Result of comparison operators `==` and `/=`. Values are `True` and `False`. -#### network+#### `Network` Represents network/subnet, created by `subnet` command and used by `subnet`, `node`, `spawn` and network configuration commands. -#### node+#### `Node` Represents network node, created by `node` command or implicitly by `spawn`, and used by `spawn` or network configuration commands.@@ -203,9 +224,9 @@ : String representation of the node primary IP address. `network`-: The network which the node belogs to.+: The network which the node belongs to. -#### process+#### `Process` Represents running process. Created by `spawn`, used by `send` and `expect` commands. @@ -217,7 +238,7 @@ `pid` : PID of the corresponding system process, `0` if there is none. -#### asset+#### `Asset` Represents an asset (file or directory), which can be used during test execution. @@ -236,9 +257,9 @@ #### list -Lists are written using bracket notation:+Lists are written using bracket notation, and brackets are also used to express the type: ```-let numbers = [1, 2, 4]+let numbers = [1, 2, 4] : [Integer] ``` List elements can be of any type, but all elements of a particular list must have the same type.@@ -416,7 +437,10 @@ and `<name>`, if given, is the name of the variable that will refer to the shell process (this can be used e.g. in the `expect` command to check the standard output of the script). As with the `spawn` command, the resulting process is terminated at the end of the current scope. +By default the shell process exists with failure whenever any command exits with non-zero status.+This behavior can be disabled using the `set +e` command (and re-enabled with `set -e`). + ### Functions When calling a function, parameters are usually passed using argument keywords@@ -469,6 +493,12 @@ parentheses: ``` def twice (x) = 2 * x+```++Type of a given parameter can be also given explicitly using the `:` notation:+```+def say (what : String) to (p : Process):+ send what to p ``` ### Modules, exports and imports
erebos-tester.cabal view
@@ -1,14 +1,17 @@ cabal-version: 3.0 name: erebos-tester-version: 0.3.5-synopsis: Test framework with virtual network using Linux namespaces+version: 0.3.6+synopsis: Test framework able to run given program on multiple nodes in virtual network description: This framework is intended mainly for networking libraries/applications and can run multiple concurrent instances of the tested application on different nodes, possibly within separate subnets, on the virtual network. Each instance can receive its own commands and produce output to be checked via standard input/output, as defined using custom script language.++ The virtual network is created using Linux namespaces, so the framework+ is Linux-specific. homepage: https://erebosprotocol.net/tester -- bug-reports: license: GPL-3.0-only@@ -39,6 +42,7 @@ Asset Config GDB+ JUnit Network Network.Ip Output@@ -51,6 +55,7 @@ Process Process.Signal Run+ Run.Builtins Run.Monad Sandbox Script.Expr@@ -62,6 +67,9 @@ Test Test.Builtins TestMode+ TextFormat+ TextFormat.Ansi+ TextFormat.Types Util Version Version.Git
src/Asset.hs view
@@ -1,6 +1,6 @@ module Asset ( Asset(..),- AssetPath(..),+ AssetPath(..), textAssetPath, ) where import Data.Text (Text)@@ -19,7 +19,7 @@ textAssetPath (AssetPath path) = T.pack path instance ExprType Asset where- textExprType _ = "asset"+ textExprType _ = "Asset" textExprValue asset = "asset:" <> textAssetPath (assetPath asset) recordMembers =@@ -27,7 +27,7 @@ ] instance ExprType AssetPath where- textExprType _ = "filepath"+ textExprType _ = "Filepath" textExprValue = ("filepath:" <>) . textAssetPath exprExpansionConvTo = cast textAssetPath
+ src/JUnit.hs view
@@ -0,0 +1,60 @@+module JUnit (+ writeJUnitReport,+) where++import Control.Monad++import Data.ByteString qualified as B+import Data.ByteString.Char8 qualified as BC+import Data.Function+import Data.List.NonEmpty qualified as NE+import Data.Scientific+import Data.Text qualified as T+import Data.Text.Encoding++import System.Directory+import System.FilePath+import System.IO++import Run+import Script.Var+++showTime :: Scientific -> B.ByteString+showTime = BC.pack . formatScientific Fixed Nothing++writeJUnitReport :: FilePath -> Report -> IO ()+writeJUnitReport path Report {..} = do+ createDirectoryIfMissing True $ takeDirectory path+ withFile path WriteMode $ \h -> do+ B.hPutStr h $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+ B.hPutStr h $ "<testsuites time=\"" <> showTime reportTotalTime <> "\">\n"+ forM_ (NE.groupBy ((==) `on` (testNameModule . reportTestName)) reportTests) $ \grp -> do+ B.hPutStr h $ "<testsuite name=\"" <> encodeUtf8 (textModuleName $ testNameModule $ reportTestName $ NE.head grp) <> "\" time=\"" <> showTime (sum $ map reportTime $ NE.toList grp) <> "\">"+ forM_ grp $ \SingleTestReport {..} -> do+ B.hPutStr h $ B.concat+ [ "<testcase name=\"", encodeUtf8 (testNameBase reportTestName), "\""+ , " classname=\"", encodeUtf8 (textModuleName $ testNameModule reportTestName), "\""+ , " time=\"", showTime reportTime, "\">"+ , "<system-out>"+ , encodeUtf8 $ escape reportOutput+ , "</system-out>"+ , case reportTestFailed of+ Nothing -> do+ ""+ Just Failed -> do+ "<failure message=\"Test failed\">" <> encodeUtf8 (escape reportOutputError) <> "</failure>"+ Just (ProcessCrashed _) -> do+ "<error message=\"Process crashed\">" <> encodeUtf8 (escape reportOutputError) <> "</error>"+ , "</testcase>"+ ]++ B.hPutStr h $ "</testsuite>"+ B.hPutStr h $ "</testsuites>\n"++ where+ escape = T.concatMap $ \case+ '&' -> "&"+ '<' -> "<"+ '>' -> ">"+ c -> T.singleton c
src/Main.hs view
@@ -1,12 +1,14 @@ module Main (main) where import Control.Monad+import Control.Monad.Reader import Data.Char import Data.Maybe import Data.Text (Text) import Data.Text qualified as T +import Text.Printf import Text.Read (readMaybe) import System.Console.GetOpt@@ -19,19 +21,21 @@ import System.Posix.Types import Config+import JUnit import Output import Parser.Core import Process-import Run+import Run.Builtins import TestMode-import Util+import TextFormat import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions- , optRepeat :: Int , optExclude :: [ Text ] , optVerbose :: Bool+ , optReport :: Bool+ , optJUnitReport :: Maybe FilePath , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool@@ -42,9 +46,10 @@ defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions- , optRepeat = 1 , optExclude = [] , optVerbose = False+ , optReport = False+ , optJUnitReport = Nothing , optColor = Nothing , optShowHelp = False , optShowVersion = False@@ -90,11 +95,20 @@ (NoArg $ to $ \opts -> opts { optKeep = True }) "keep test directory even if all tests succeed" , Option ['r'] ["repeat"]- (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>")+ (ReqArg (\str -> to $ \opts -> opts { optRepeat = read str }) "<count>") "number of times to repeat the test(s)" , Option [ 'e' ] [ "exclude" ] (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test|tag>") "exclude given test or test tag from execution"+ , Option [] [ "keep-going" ]+ (NoArg $ to $ \opts -> opts { optKeepGoing = True })+ "keep going after a failed test"+ , Option [] [ "report" ]+ (NoArg $ \opts -> opts { optReport = True, optTest = (optTest opts) { optKeepGoing = True } })+ "print summary of passing and failing tests (implies --keep-going)"+ , Option [] [ "junit-report" ]+ (ReqArg (\str opts -> opts { optJUnitReport = Just str, optTest = (optTest opts) { optKeepGoing = True } }) "<path>")+ "write test report in JUnit XML format to <path> (implies --keep-going)" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test"@@ -207,9 +221,35 @@ let topts = (optTest opts) { optTcpdump = tcpdump }- ok <- allM (runTest out topts lmGlobalDefs) $- concat $ replicate (optRepeat opts) tests- when (not ok) exitFailure++ report@Report {..} <- runTests out topts lmGlobalDefs tests++ when (optReport opts) $ flip runReaderT out $ do+ outLineF OutputGlobalSummary Nothing $ "Total tests: " <> plainText (T.pack (show reportTotalCount))+ let ( mins, secs ) = (floor reportTotalTime :: Integer) `quotRem` 60+ csecs = floor (reportTotalTime * 100) `rem` 100 :: Integer+ outLineF OutputGlobalSummary Nothing $ "Total time: " <> plainText (T.pack $ printf "%d:%02d.%02d" mins secs csecs)+ outLineF OutputGlobalSummary Nothing $ mconcat+ [ "Passed tests: "+ , withStyle (if (reportPassedCount > 0) then setForegroundColor Green noStyle else noStyle) $+ plainText $ T.pack $ show reportPassedCount+ ]+ outLineF OutputGlobalSummary Nothing $ mconcat+ [ "Failed tests: "+ , withStyle (if (reportFailedCount > 0) then setForegroundColor Red noStyle else noStyle) $+ plainText (T.pack (show reportFailedCount))+ ]+ when (reportFailedCount > 0) $ do+ outLine OutputGlobalSummary Nothing ""+ outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failed tests:"+ forM_ reportFailedList $ \tname -> do+ outLineF OutputGlobalSummary Nothing $+ withStyle (setForegroundColor Red noStyle) $+ plainText $ textTestName tname++ forM_ (optJUnitReport opts) $ \path -> writeJUnitReport path report++ when (reportFailedCount > 0) exitFailure exitOnError :: Either CustomTestError a -> IO a exitOnError (Left err) = do
src/Network.hs view
@@ -101,11 +101,11 @@ instance HasNetns Node where getNetns = nodeNetns instance ExprType Network where- textExprType _ = T.pack "network"+ textExprType _ = T.pack "Network" textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where- textExprType _ = T.pack "node"+ textExprType _ = T.pack "Node" textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">" recordMembers = map (first T.pack)@@ -123,10 +123,11 @@ newInternet :: MonadIO m => FilePath -> m Internet newInternet dir = do+ adir <- liftIO $ makeAbsolute dir atomicallyWithIO $ do Internet- <$> pure dir- <*> newNetwork (IpPrefix [1]) dir+ <$> pure adir+ <*> newNetwork (IpPrefix [1]) adir delInternet :: MonadIO m => Internet -> m () delInternet _ = liftIO $ do
src/Output.hs view
@@ -3,9 +3,13 @@ MonadOutput(..), startOutput, resetOutputTime,+ getElapsedTime, outLine,+ outLineF, outPromptGetLine, outPromptGetLineCompletion,+ collectOutput,+ collectErrorOutput, ) where import Control.Concurrent.MVar@@ -13,6 +17,7 @@ import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Scientific import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL@@ -27,6 +32,10 @@ import Script.Expr +import TextFormat+import TextFormat.Ansi++ data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig@@ -41,6 +50,8 @@ data OutputState = OutputState { outPrint :: TL.Text -> IO () , outHistory :: History+ , outLines :: [ Text ]+ , outErrLines :: [ Text ] } data OutputStyle@@ -52,6 +63,7 @@ data OutputType = OutputGlobalInfo | OutputGlobalError+ | OutputGlobalSummary | OutputChildStdout | OutputChildStderr | OutputChildStdin@@ -73,7 +85,12 @@ startOutput :: OutputStyle -> Bool -> IO Output startOutput outStyle outUseColor = do- outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }+ outState <- newMVar OutputState+ { outPrint = TL.putStrLn+ , outHistory = emptyHistory+ , outLines = []+ , outErrLines = []+ } outConfig <- pure OutputConfig {..} outStartedAt <- newMVar =<< getTime Monotonic hSetBuffering stdout LineBuffering@@ -83,10 +100,17 @@ resetOutputTime Output {..} = do modifyMVar_ outStartedAt . const $ getTime Monotonic +getElapsedTime :: Output -> IO Scientific+getElapsedTime Output {..} = do+ stime <- readMVar outStartedAt+ (/ 1000000000) . fromIntegral . toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic++ outColor :: OutputType -> Text outColor = \case OutputGlobalInfo -> "0" OutputGlobalError -> "31"+ OutputGlobalSummary -> "0" OutputChildStdout -> "0" OutputChildStderr -> "31" OutputChildStdin -> "0"@@ -104,6 +128,7 @@ outSign = \case OutputGlobalInfo -> "" OutputGlobalError -> ""+ OutputGlobalSummary -> "" OutputChildStdout -> " " OutputChildStderr -> "!" OutputChildStdin -> T.empty@@ -121,6 +146,7 @@ outArr = \case OutputGlobalInfo -> "" OutputGlobalError -> ""+ OutputGlobalSummary -> "" OutputChildStdin -> "<" _ -> ">" @@ -128,6 +154,7 @@ outTestLabel = \case OutputGlobalInfo -> "global-info" OutputGlobalError -> "global-error"+ OutputGlobalSummary -> "global-summary" OutputChildStdout -> "child-stdout" OutputChildStderr -> "child-stderr" OutputChildStdin -> "child-stdin"@@ -143,56 +170,77 @@ printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case+ OutputGlobalSummary -> True+ OutputAlways -> True+ t -> printIsError t++printIsError :: OutputType -> Bool+printIsError = \case OutputGlobalError -> True OutputChildStderr -> True OutputChildFail -> True OutputMatchFail {} -> True OutputError -> True- OutputAlways -> True _ -> False includeTestTime :: OutputType -> Bool includeTestTime = \case OutputGlobalInfo -> False OutputGlobalError -> False+ OutputGlobalSummary -> False _ -> True ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a ioWithOutput act = liftIO . act =<< getOutput outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()-outLine otype prompt line = ioWithOutput $ \out ->+outLine otype prompt line = outLineF otype prompt (plainText line)++outLineF :: MonadOutput m => OutputType -> Maybe Text -> FormattedText -> m ()+outLineF otype prompt line = ioWithOutput $ \out -> case outStyle (outConfig out) of- OutputStyleQuiet- | printWhenQuiet otype -> normalOutput out- | otherwise -> return ()- OutputStyleVerbose -> normalOutput out+ OutputStyleQuiet -> normalOutput (printWhenQuiet otype) out+ OutputStyleVerbose -> normalOutput True out OutputStyleTest -> testOutput out where- normalOutput out = do- stime <- readMVar (outStartedAt out)- nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic- withMVar (outState out) $ \st -> do- forM_ (normalOutputLines otype line) $ \line' -> do- outPrint st $ TL.fromChunks $ concat- [ if includeTestTime otype- then [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]- else []- , if outUseColor (outConfig out)- then [ T.pack "\ESC[", outColor otype, T.pack "m" ]- else []- , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]- , [ line' ]- , if outUseColor (outConfig out)- then [ T.pack "\ESC[0m" ]- else []- ]+ normalOutput normal out = do+ secs <- getElapsedTime out + let formatLine color line' = T.concat $ concat+ [ if includeTestTime otype+ then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ]+ else []+ , if color+ then [ T.pack "\ESC[", outColor otype, T.pack "m" ]+ else []+ , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]+ , [ line' ]+ , if color+ then [ T.pack "\ESC[0m" ]+ else []+ ]++ modifyMVar_ (outState out) $ \ost -> do+ (\f -> foldM f ost (normalOutputLines otype $ renderLine out line)) $ \st line' -> do+ when normal $ do+ outPrint st $ TL.fromStrict $ formatLine (outUseColor (outConfig out)) line'+ return st+ { outLines = formatLine False line' : outLines st+ , outErrLines = (if printIsError otype+ then (formatLine False line' :)+ else id) $ outErrLines st+ }++ renderLine out+ | outUseColor (outConfig out) = fromAnsiText . renderAnsiText+ | otherwise = renderPlainText+ testOutput out = do+ let pline = renderPlainText line withMVar (outState out) $ \st -> do case otype of- OutputTestRaw -> outPrint st $ TL.fromStrict line- _ -> forM_ (testOutputLines otype (maybe "-" id prompt) line) $ outPrint st . TL.fromStrict+ OutputTestRaw -> outPrint st $ TL.fromStrict pline+ _ -> forM_ (testOutputLines otype (maybe "-" id prompt) pline) $ outPrint st . TL.fromStrict normalOutputLines :: OutputType -> Text -> [ Text ]@@ -246,3 +294,14 @@ return (x, st' { outPrint = outPrint st, outHistory = hist' }) putMVar (outState out) st' return $ fmap T.pack x+++collectOutput :: Output -> IO Text+collectOutput Output {..} = do+ modifyMVar outState $ \st -> do+ return ( st { outLines = [] }, T.unlines $ reverse $ outLines st )++collectErrorOutput :: Output -> IO Text+collectErrorOutput Output {..} = do+ modifyMVar outState $ \st -> do+ return ( st { outErrLines = [] }, T.unlines $ reverse $ outErrLines st )
src/Parser.hs view
@@ -44,7 +44,10 @@ { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar } href <- L.indentLevel- testName <- header+ testNameBase <- header+ testNameModule <- gets testCurrentModuleName+ let testName = TestName {..}+ osymbol ":" <* eol <* scn ref <- L.indentGuard scn GT href@@ -77,11 +80,12 @@ def@( name, expr ) <- localState $ do wsymbol "def" name <- varName- argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)- atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do- tvar <- newTypeVar- modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, ExprTypeVar tvar )) : testVars s }- return ( off, vname, tvar )+ argsDecl <- functionArguments (\off _ -> return . ( off, ))+ (typeAnnotated varName) mzero (\_ -> return . (, Nothing) . VarName)+ atypes <- forM argsDecl $ \( off, ( vname :: VarName, mbstype :: Maybe SomeExprType ) ) -> do+ stype <- maybe (ExprTypeVar <$> newTypeVar) return mbstype+ modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, stype )) : testVars s }+ return ( off, vname, stype ) SomeExpr expr <- choice [ do osymbol ":"@@ -99,13 +103,8 @@ modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } return def where- getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do- let err msg = do- registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg- return ( vname, SomeArgumentType OptionalArgument (ExprTypeForall (TypeVar "a") (ExprTypeVar (TypeVar "a"))) )- gets (M.lookup tvar . testTypeUnif) >>= \case- Just t -> return ( vname, SomeArgumentType RequiredArgument t )- Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"+ getInferredTypes atypes = forM atypes $ \( _, vname, stype ) -> do+ ( vname, ) . SomeArgumentType OptionalArgument <$> typeClosure stype replaceDynArgs :: forall a. Expr a -> TestParser (Expr a) replaceDynArgs expr = do@@ -122,6 +121,18 @@ replaceArgs (SomeExpr e) = SomeExpr (go unif e) e -> e + typeAnnotated p = do+ x <- p+ choice+ [ do+ void $ osymbol ":"+ stype <- typeExpr+ return ( x, Just stype )++ , do+ return ( x, Nothing )+ ]+ parseAsset :: Pos -> TestParser ( VarName, SomeExpr ) parseAsset href = label "asset definition" $ do wsymbol "asset"@@ -210,23 +221,24 @@ eof return Module {..} -parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))-parseTestFiles paths = do+parseTestFiles :: [ SomePrimType ] -> [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))+parseTestFiles builtinTypes paths = do parsedModules <- newIORef [] runExceptT $ do requestedModules <- reverse <$> foldM (go parsedModules) [] paths allModules <- map snd <$> liftIO (readIORef parsedModules) return ( requestedModules, allModules ) where+ builtinTypes' = map (\(SomePrimType p) -> ( VarName (textExprType p), ExprTypePrim p )) builtinTypes go parsedModules res path = do- liftIO (parseTestFile parsedModules Nothing path) >>= \case+ liftIO (parseTestFile builtinTypes' parsedModules Nothing path) >>= \case Left err -> do throwError err Right cur -> do return $ cur : res -parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)-parseTestFile parsedModules mbModuleName path = do+parseTestFile :: [ ( VarName, SomeExprType ) ] -> IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)+parseTestFile builtinTypes parsedModules mbModuleName path = do absPath <- makeAbsolute path (lookup absPath <$> readIORef parsedModules) >>= \case Just found -> return $ Right found@@ -236,13 +248,14 @@ , testVars = concat [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins ]+ , testTypeVars = builtinTypes , testContext = SomeExpr (Undefined "void" :: Expr Void) , testNextTypeVar = 0 , testTypeUnif = M.empty , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do let projectRoot = iterate takeDirectory absPath !! length current- parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath+ parseTestFile builtinTypes parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath } mbContent <- (Just <$> TL.readFile path) `catchIOError` \e -> if isDoesNotExistError e then return Nothing else ioError e
src/Parser/Core.hs view
@@ -4,7 +4,9 @@ import Control.Arrow import Control.Monad import Control.Monad.State+import Control.Monad.Writer +import Data.List import Data.Map (Map) import Data.Map qualified as M import Data.Maybe@@ -23,6 +25,7 @@ import Script.Expr.Class import Script.Module import Test+import Util newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) deriving@@ -92,6 +95,7 @@ data TestParserState = TestParserState { testSourcePath :: FilePath , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ]+ , testTypeVars :: [ ( VarName, SomeExprType ) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType@@ -138,26 +142,45 @@ SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) stype -> return $ SomeExpr $ DynVariable stype sline fqn +lookupType :: Int -> VarName -> TestParser SomeExprType+lookupType off name = do+ gets (lookup name . testTypeVars) >>= \case+ Nothing -> do+ registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $+ "type not in scope: ‘" <> textVarName name <> "’"+ return $ ExprTypeVar (TypeVar $ textVarName name)+ Just x -> return x -resolveKnownTypeVars :: SomeExprType -> TestParser SomeExprType-resolveKnownTypeVars stype = case stype of- ExprTypePrim {} -> return stype- ExprTypeConstr1 {} -> return stype- ExprTypeVar tvar -> do- gets (M.lookup tvar . testTypeUnif) >>= \case- Just stype' -> resolveKnownTypeVars stype'- Nothing -> return stype- ExprTypeFunction args body -> ExprTypeFunction <$> resolveKnownTypeVars args <*> resolveKnownTypeVars body- ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> resolveKnownTypeVars t) args- ExprTypeApp ctor params -> do- ctor' <- resolveKnownTypeVars ctor- params' <- mapM resolveKnownTypeVars params- return $ case ( ctor', params' ) of- ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )- -> ExprTypePrim (Proxy :: Proxy (c' p'))- _ -> ExprTypeApp ctor' params'- ExprTypeForall tvar inner -> ExprTypeForall tvar <$> resolveKnownTypeVars inner +resolveKnownTypeVars :: SomeExprType -> TestParser ( SomeExprType, [ TypeVar ] )+resolveKnownTypeVars = fmap (fmap (uniq . sort)) . runWriterT . go+ where+ go stype = case stype of+ ExprTypePrim {} -> return stype+ ExprTypeConstr1 {} -> return stype+ ExprTypeVar tvar -> do+ gets (M.lookup tvar . testTypeUnif) >>= \case+ Just stype' -> go stype'+ Nothing -> tell [ tvar ] >> return stype+ ExprTypeFunction args body -> ExprTypeFunction <$> go args <*> go body+ ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> go t) args+ ExprTypeApp ctor params -> do+ ctor' <- go ctor+ params' <- mapM go params+ return $ case ( ctor', params' ) of+ ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] )+ -> ExprTypePrim (Proxy :: Proxy (c' p'))+ _ -> ExprTypeApp ctor' params'+ ExprTypeForall tvar inner -> ExprTypeForall tvar <$> go inner++typeClosure :: SomeExprType -> TestParser SomeExprType+typeClosure stype = do+ ( stype', freeVars ) <- resolveKnownTypeVars stype+ return $ go freeVars stype'+ where+ go [] t = t+ go (v : vs) t = ExprTypeForall v $ go vs t+ unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do cur <- gets testTypeUnif@@ -316,11 +339,9 @@ arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument" ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def )- ( kw, SomeArgumentType ContextDefault (ExprTypePrim atype) ) -> do- SomeExpr context <- gets testContext- context' <- unifyExpr off atype context- return $ Just ( kw, SomeExpr context' )- ( _, SomeArgumentType ContextDefault _ ) -> err "non-primitive context requirement"+ ( kw, SomeArgumentType ContextDefault atype ) -> do+ context <- unifySomeExpr off atype =<< gets testContext+ return $ Just ( kw, context ) sline <- getSourceLine return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) @@ -401,7 +422,7 @@ wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s)-operatorChar = satisfy $ (`elem` [ '.', '+', '-', '*', '/', '=', '<', '>', '|' ])+operatorChar = satisfy $ (`elem` [ '!', '%', '&', '*', '+', '-', '.', '/', ':', '<', '=', '>', '?', '@', '^', '|', '~' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a
src/Parser/Expr.hs view
@@ -14,10 +14,14 @@ variable, constructor, + someExpansion, expansionTypeCheck,+ expressionExpansion, stringExpansion, functionArguments, applyFunctionArguments,++ typeExpr, ) where import Control.Applicative (liftA2)@@ -107,10 +111,8 @@ , between (char '{') (char '}') (someExpr FunctionTerm) ] -expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)-expressionExpansion tname = do- off <- stateOffset <$> getParserState- SomeExpr e <- someExpansion+expansionTypeCheck :: forall a. ExprType a => Int -> Text -> SomeExpr -> TestParser (Expr a)+expansionTypeCheck off tname (SomeExpr e) = do let err = do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ]@@ -118,6 +120,11 @@ maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a)+expressionExpansion tname = do+ off <- stateOffset <$> getParserState+ expansionTypeCheck off tname =<< someExpansion+ stringExpansion :: TestParser (Expr Text) stringExpansion = expressionExpansion "string" @@ -265,7 +272,7 @@ SimpleTerm -> join termSimple FunctionTerm -> join inner where- inner = makeExprParser termFunction table+ inner = typeAnnotated $ makeExprParser termFunction table parens = between (symbol "(") (symbol ")") @@ -409,6 +416,24 @@ region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops + typeAnnotated :: TestParser (TestParser SomeExpr) -> TestParser (TestParser SomeExpr)+ typeAnnotated p = do+ off <- stateOffset <$> getParserState+ p' <- p+ choice+ [ do+ -- colon starts a type annotation, except when at the end of line+ void $ try $ (string ":" <* notFollowedBy operatorChar <* sc <* notFollowedBy eol)+ stype <- typeExpr+ return $ do+ se <- p'+ unifySomeExpr off stype se++ , do+ return p'+ ]++ typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a) typedExpr complexity = do off <- stateOffset <$> getParserState@@ -503,9 +528,9 @@ unexpectedArguments unexpectedArgs t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif resolveKnownTypeVars res' >>= \case- res''@(ExprTypePrim (Proxy :: Proxy r)) ->+ ( res''@(ExprTypePrim (Proxy :: Proxy r)), _ ) -> return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r)))- r ->+ ( r, _ ) -> return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType))) _ -> do unexpectedArguments args@@ -517,7 +542,7 @@ ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args unexpectedArguments unexpectedArgs resolveKnownTypeVars res' >>= \case- ExprTypePrim (Proxy :: Proxy r)+ ( ExprTypePrim (Proxy :: Proxy r), _ ) | Just (Refl :: a :~: FunctionType r) <- eqT -> return $ SomeExpr (ArgsApp used expr) _@@ -535,3 +560,17 @@ case kw of Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" Nothing -> "unexpected parameter"+++typeExpr :: TestParser SomeExprType+typeExpr = do+ off <- stateOffset <$> getParserState+ choice+ [ do+ name <- constrName <?> "type constructor name"+ lookupType off name+ , do+ between (symbol "[") (symbol "]") $ do+ inner <- typeExpr+ return $ ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ inner ]+ ]
src/Parser/Shell.hs view
@@ -71,41 +71,76 @@ parseRedirection :: TestParser (Expr ShellArgument) parseRedirection = choice [ do- osymbol "<"+ rsymbol "<" fmap ShellRedirectStdin <$> parseTextArgument , do- osymbol ">"+ rsymbol ">" fmap (ShellRedirectStdout False) <$> parseTextArgument , do- osymbol ">>"+ rsymbol ">>" fmap (ShellRedirectStdout True) <$> parseTextArgument , do- osymbol "2>"+ rsymbol "2>" fmap (ShellRedirectStderr False) <$> parseTextArgument , do- osymbol "2>>"+ rsymbol "2>>" fmap (ShellRedirectStderr True) <$> parseTextArgument ]+ where+ rsymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|' ]))) <* sc parseArgument :: TestParser (Expr ShellArgument) parseArgument = choice [ parseRedirection+ , expressionExpansion "shell argument" <* sc , fmap ShellArgument <$> parseTextArgument ] -parseArguments :: TestParser (Expr [ ShellArgument ])-parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument+parseArguments :: TestParser (Expr ShellArguments)+parseArguments = do+ arglists <- many $ choice+ [ do+ off <- stateOffset <$> getParserState+ se <- someExpansion+ choice+ [ do+ notFollowedBy space1+ arg <- expansionTypeCheck off "shell argument" se+ txt <- parseTextArgument+ return $ joinArgument <$> arg <*> txt+ , do+ expansionTypeCheck off "shell arguments" se <* sc+ ]+ , fmap (ShellArguments . (: [])) <$> parseArgument+ ]+ return $ fmap mconcat $ foldr (liftA2 (:)) (Pure []) $ arglists+ where+ joinArgument (ShellArgument x) y = ShellArguments [ ShellArgument (x <> y) ]+ joinArgument ax y = ShellArguments [ ax, ShellArgument y ] parseCommand :: TestParser (Expr ShellCommand) parseCommand = label "shell statement" $ do line <- getSourceLine- command <- parseTextArgument- args <- parseArguments- return $ ShellCommand- <$> command- <*> args- <*> pure line+ choice+ [ do+ args <- expressionExpansion "shell command" <* sc+ args' <- parseArguments+ return $ commandFromArgLists line <$> args <*> args'+ , do+ command <- parseTextArgument+ args <- parseArguments+ return $ ShellCommand+ <$> command+ <*> args+ <*> pure line+ ] + where+ commandFromArgLists line (ShellArguments (ShellArgument cmd : args)) (ShellArguments args') =+ ShellCommand cmd (ShellArguments (args ++ args')) line+ commandFromArgLists line (ShellArguments args) (ShellArguments args') =+ ShellCommand "" (ShellArguments (args ++ args')) line+ parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline) parsePipeline mbupper = do cmd <- parseCommand@@ -115,12 +150,14 @@ Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper choice [ do- osymbol "|"+ psymbol "|" parsePipeline (Just pipeline) , do return pipeline ]+ where+ psymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|', '&' ]))) <* sc parseStatement :: TestParser (Expr [ ShellStatement ]) parseStatement = do
src/Parser/Statement.hs view
@@ -295,7 +295,7 @@ combine _ [] = error "inner block parameter count mismatch" innerBlock :: CommandDef (TestStep ())-innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFun+innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFunList innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList@@ -335,6 +335,9 @@ | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables , Just (Refl :: p :~: InnerBlock a) <- eqT -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials++ | Just (Refl :: p :~: InnerBlock Void) <- eqT+ -> SomeParam p . Identity . ( [], ) <$> restOfParts cmdi partials (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p
src/Process.hs view
@@ -66,7 +66,7 @@ (==) = (==) `on` procStdin instance ExprType Process where- textExprType _ = T.pack "proc"+ textExprType _ = T.pack "Process" textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack)
src/Run.hs view
@@ -1,9 +1,12 @@ module Run ( module Run.Monad,+ Report(..), SingleTestReport(..),+ TestName, textTestName,+ runTests, runTest, LoadedModules(..),- loadModules,+ loadModules', evalGlobalDefs, TestFilter(..),@@ -12,6 +15,7 @@ ) where import Control.Applicative+import Control.Arrow import Control.Concurrent import Control.Concurrent.STM import Control.Monad@@ -19,7 +23,7 @@ import Control.Monad.Reader import Control.Monad.Writer -import Data.Bifunctor+import Data.Char import Data.Either import Data.List import Data.Map qualified as M@@ -32,6 +36,7 @@ import Data.Typeable import System.Directory+import System.FilePath import System.Exit import System.IO.Error import System.Posix.Process@@ -56,9 +61,59 @@ import Test.Builtins -runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool+data Report = Report+ { reportTotalCount :: Int+ , reportPassedCount :: Int+ , reportSkippedCount :: Int+ , reportFailedCount :: Int+ , reportFailedList :: [ TestName ]+ , reportTotalTime :: Scientific+ , reportTests :: [ SingleTestReport ]+ }++data SingleTestReport = SingleTestReport+ { reportTestName :: TestName+ , reportTestFailed :: Maybe Failed+ , reportTime :: Scientific+ , reportOutput :: Text+ , reportOutputError :: Text+ }++runTests :: Output -> TestOptions -> GlobalDefs -> [ Test ] -> IO Report+runTests out opts gdefs tests = do+ go $ concat $ replicate (optRepeat opts) tests+ where+ go (t : ts) = do+ single <- runTest out opts gdefs t+ let failed = isJust (reportTestFailed single)+ r <- if+ | failed && not (optKeepGoing opts)+ -> go []+ | otherwise+ -> go ts+ return Report+ { reportTotalCount = 1 + reportTotalCount r+ , reportPassedCount = (if failed then 0 else 1) + reportPassedCount r+ , reportSkippedCount = reportSkippedCount r+ , reportFailedCount = (if failed then 1 else 0) + reportFailedCount r+ , reportFailedList = (if failed then (reportTestName single :) else id) $ reportFailedList r+ , reportTotalTime = reportTime single + reportTotalTime r+ , reportTests = single : reportTests r+ }+ go [] = return Report+ { reportTotalCount = 0+ , reportPassedCount = 0+ , reportSkippedCount = 0+ , reportFailedCount = 0+ , reportFailedList = []+ , reportTotalTime = 0+ , reportTests = []+ }+++runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO SingleTestReport runTest out opts gdefs test = do- let testDir = optTestDir opts+ 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@@ -81,6 +136,7 @@ { teOutput = out , teFailed = failedVar , teOptions = opts+ , teTestDir = testDir , teNextObjId = objIdVar , teNextProcId = procIdVar , teProcesses = procVar@@ -113,12 +169,12 @@ Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing + flip runReaderT out $ do+ void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> textTestName (testName test) <> "’"+ resetOutputTime out testRunResult <- newEmptyMVar - flip runReaderT out $ do- void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> testName test <> "’"- void $ forkOS $ do isolateFilesystem testDir >>= \case True -> do@@ -126,12 +182,15 @@ 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, [] ) ( res, [] ) <- takeMVar testRunResult+ reportTime <- getElapsedTime out+ reportOutput <- collectOutput out+ reportOutputError <- collectErrorOutput out void $ installHandler processStatusChanged oldHandler Nothing @@ -140,31 +199,35 @@ [] <- readMVar procVar failed <- atomically $ readTVar (teFailed tenv)- case (res, failed) of- (Right (), Nothing) -> do+ reportTestFailed <- case ( res, failed ) of+ ( Right (), Nothing ) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir- return True+ return Nothing _ -> do flip runReaderT out $ do- void $ outLine OutputGlobalError Nothing $ "Test ‘" <> testName test <> "’ failed."- return False+ void $ outLine OutputGlobalError Nothing $ "Test ‘" <> textTestName (testName test) <> "’ failed."+ return $ either Just (const Nothing) res `mplus` failed + (optHookTestResult opts) (testName test) (isNothing reportTestFailed)+ let reportTestName = testName test+ return SingleTestReport {..} + data LoadedModules = LoadedModules { lmModules :: [ Module ]- , lmTags :: [ ( ( ModuleName, Text ), [ Tag ] ) ]+ , lmTags :: [ ( TestName, [ Tag ] ) ] , lmGlobalDefs :: GlobalDefs } -loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)-loadModules files = do- parseTestFiles (map fst files) >>= \case+loadModules' :: [ SomePrimType ] -> [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)+loadModules' builtinTypes files = do+ parseTestFiles builtinTypes (map fst files) >>= \case Right ( modules, allModules ) -> return $ do lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> 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)@@ -172,7 +235,7 @@ 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@@ -203,25 +266,52 @@ filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ] filterTests TestFilter {..} LoadedModules {..} = do- let allTests = concatMap (\m -> ( moduleName m, ) <$> moduleTests m) lmModules- let evalTerm :: Text -> Either CustomTestError (Either Text Tag)- evalTerm t =- case find ((VarName t ==) . snd . fst) $ M.toList lmGlobalDefs of- Just ( _, SomeExpr (expr :: Expr etype))- | Just (Refl :: etype :~: Tag) <- eqT- -> return $ Right $ runSimpleEval (eval expr) lmGlobalDefs []- Nothing- | Just _ <- find ((t ==) . testName . snd) 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 allTests = concatMap moduleTests lmModules+ let evalTerm :: Text -> Either CustomTestError (Either TestName (Either Tag ModuleName))+ evalTerm term =+ case (init &&& last) $ T.splitOn "." term of+ ( [], name ) | maybe False (isUpper . fst) (T.uncons name) ->+ case find ((VarName name ==) . snd . fst) $ M.toList lmGlobalDefs of+ Just ( _, SomeExpr (expr :: Expr etype) )+ | Just (Refl :: etype :~: Tag) <- eqT+ -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs []+ Nothing+ | Just t <- find ((name ==) . testNameBase . testName) allTests+ -> return $ Left $ testName t+ Nothing+ | mname <- ModuleName [ name ]+ , Just _ <- find ((mname ==) . moduleName) lmModules+ -> return $ Right $ Right mname+ _ ->+ throwError $ TestOrTagNotFound term Nothing+ ( ms, name ) | maybe False (isUpper . fst) (T.uncons name) ->+ case find ((( ModuleName ms, VarName name ) ==) . fst) $ M.toList lmGlobalDefs of+ Just ( _, SomeExpr (expr :: Expr etype) )+ | Just (Refl :: etype :~: Tag) <- eqT+ -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs []+ Nothing+ | Just t <- find ((TestName (ModuleName ms) name ==) . testName) allTests+ -> return $ Left $ testName t+ Nothing+ | mname <- ModuleName $ ms ++ [ name ]+ , Just _ <- find ((mname ==) . moduleName) lmModules+ -> return $ Right $ Right mname+ _ ->+ throwError $ TestOrTagNotFound term Nothing+ ( ms, name ) | mname <- ModuleName $ ms ++ [ name ] ->+ case find ((mname ==) . moduleName) lmModules of+ Just _ -> return $ Right $ Right mname+ _ -> throwError $ ModuleNotFound mname++ exclude <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tfExclude+ let matches ( tnames, ( tags, modules ) ) test =+ testName test `elem` tnames+ || maybe False (any (`elem` tags)) (lookup (testName test) lmTags)+ || testNameModule (testName test) `elem` modules+ filter (not . matches exclude) <$> case tfSelect of Nothing -> return allTests Just tnames -> do- selected <- partitionEithers <$> mapM evalTerm tnames+ selected <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tnames return $ filter (matches selected) allTests @@ -302,7 +392,7 @@ withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do- testDir <- asks $ optTestDir . teOptions . fst+ testDir <- asks $ teTestDir . fst inet <- newInternet testDir flip finally (delInternet inet) $ do withNetwork (inetRoot inet) $ \net -> do
+ src/Run/Builtins.hs view
@@ -0,0 +1,43 @@+module Run.Builtins (+ module Run,+ loadModules,+) where++import Data.Proxy+import Data.Scientific+import Data.Text (Text)+import Data.Void++import Asset (Asset)+import Network (Network, Node)+import Parser (CustomTestError)+import Process (Process)+import Process.Signal (Signal)+import Run+import Script.Expr+import Test (Test, Tag)+++builtinTypes :: [ SomePrimType ]+builtinTypes =+ [ SomePrimType @() Proxy+ , SomePrimType @Integer Proxy+ , SomePrimType @Scientific Proxy+ , SomePrimType @Bool Proxy+ , SomePrimType @Text Proxy+ , SomePrimType @Void Proxy+ , SomePrimType @Regex Proxy++ , SomePrimType @Test Proxy+ , SomePrimType @Tag Proxy+ , SomePrimType @Asset Proxy++ , SomePrimType @Network Proxy+ , SomePrimType @Node Proxy++ , SomePrimType @Process Proxy+ , SomePrimType @Signal Proxy+ ]++loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules)+loadModules = loadModules' builtinTypes
src/Run/Monad.hs view
@@ -43,6 +43,7 @@ { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions+ , teTestDir :: FilePath , teNextObjId :: MVar Int , teNextProcId :: MVar Int , teProcesses :: MVar [ Process ]@@ -67,7 +68,10 @@ , optGDB :: Bool , optForce :: Bool , optKeep :: Bool+ , optRepeat :: Int+ , optKeepGoing :: Bool , optWait :: Bool+ , optHookTestResult :: TestName -> Bool -> IO () } defaultTestOptions :: TestOptions@@ -80,7 +84,10 @@ , optGDB = False , optForce = False , optKeep = False+ , optRepeat = 1+ , optKeepGoing = False , optWait = False+ , optHookTestResult = \_ _ -> return () } data Failed = Failed
src/Script/Expr.hs view
@@ -8,6 +8,7 @@ FunctionType, DynamicType, ExprType(..), SomeExpr(..),+ SomePrimType(..), TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, renameTypeVar, renameVarInType, @@ -293,6 +294,8 @@ data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) +data SomePrimType = forall a. ExprType a => SomePrimType (Proxy a)+ newtype TypeVar = TypeVar Text deriving (Eq, Ord) @@ -569,7 +572,7 @@ | RegexString Text instance ExprType Regex where- textExprType _ = T.pack "regex"+ textExprType _ = T.pack "Regex" textExprValue _ = T.pack "<regex>" exprExpansionConvFrom = listToMaybe $ catMaybes
src/Script/Expr/Class.hs view
@@ -57,7 +57,7 @@ textExprValue () = "()" instance ExprType Integer where- textExprType _ = T.pack "integer"+ textExprType _ = T.pack "Integer" textExprValue x = T.pack (show x) exprExpansionConvTo = listToMaybe $ catMaybes@@ -67,7 +67,7 @@ exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo instance ExprType Scientific where- textExprType _ = T.pack "number"+ textExprType _ = T.pack "Number" textExprValue x = T.pack (show x) exprExpansionConvTo = listToMaybe $ catMaybes@@ -75,16 +75,16 @@ ] instance ExprType Bool where- textExprType _ = T.pack "bool"- textExprValue True = T.pack "true"- textExprValue False = T.pack "false"+ textExprType _ = T.pack "Bool"+ textExprValue True = T.pack "True"+ textExprValue False = T.pack "False" instance ExprType Text where- textExprType _ = T.pack "string"+ textExprType _ = T.pack "String" textExprValue x = T.pack (show x) instance ExprType Void where- textExprType _ = T.pack "void"+ textExprType _ = T.pack "Void" textExprValue _ = T.pack "<void>" instance ExprType a => ExprType [ a ] where
src/Script/Shell.hs view
@@ -3,7 +3,7 @@ ShellStatement(ShellStatement), ShellPipeline(ShellPipeline), ShellCommand(ShellCommand),- ShellArgument(..),+ ShellArguments(..), ShellArgument(..), withShellProcess, ) where @@ -15,14 +15,17 @@ import Control.Monad.Reader import Data.Maybe+import Data.Scientific import Data.Text (Text) import Data.Text qualified as T+import Data.Typeable import Foreign.C.Types import Foreign.Ptr import Foreign.Marshal.Array import Foreign.Storable +import System.Directory import System.Exit import System.FilePath import System.IO@@ -31,6 +34,7 @@ import System.Posix.Types import System.Process hiding (ShellCommand) +import Asset import Network import Network.Ip import Output@@ -42,6 +46,13 @@ newtype ShellScript = ShellScript [ ShellStatement ] +data ShellState = ShellState+ { shellWorkingDirectory :: FilePath+ , shellOldWorkingDirectory :: FilePath+ , shellExitOnError :: Bool+ , shellLastExitCode :: ExitCode+ }+ data ShellStatement = ShellStatement { shellPipeline :: ShellPipeline , shellSourceLine :: SourceLine@@ -54,10 +65,13 @@ data ShellCommand = ShellCommand { cmdCommand :: Text- , cmdExtArguments :: [ ShellArgument ]+ , cmdExtArguments :: ShellArguments , cmdSourceLine :: SourceLine } +newtype ShellArguments = ShellArguments { fromShellArguments :: [ ShellArgument ] }+ deriving (Semigroup, Monoid)+ data ShellArgument = ShellArgument Text | ShellRedirectStdin Text@@ -65,7 +79,7 @@ | ShellRedirectStderr Bool Text cmdArguments :: ShellCommand -> [ Text ]-cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . cmdExtArguments+cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . fromShellArguments . cmdExtArguments instance ExprType ShellScript where textExprType _ = T.pack "ShellScript"@@ -83,11 +97,34 @@ textExprType _ = T.pack "ShellCommand" textExprValue _ = "<shell-command>" +instance ExprType ShellArguments where+ textExprType _ = T.pack "ShellArguments"+ textExprValue _ = "<shell-arguments>"+ exprExpansionConvFrom = shellExpansionTemplate+ (Just (ShellArguments . (: []) . ShellArgument))+ (Just (ShellArguments . map ShellArgument))+ instance ExprType ShellArgument where textExprType _ = T.pack "ShellArgument" textExprValue _ = "<shell-argument>"+ exprExpansionConvFrom = shellExpansionTemplate (Just ShellArgument) Nothing +shellExpansionTemplate :: forall a b. (Typeable a, ExprType b) => Maybe (Text -> a) -> Maybe ([ Text ] -> a) -> Maybe (b -> a)+shellExpansionTemplate fromSingle fromList = listToMaybe $ catMaybes+ [ single id+ , single (T.pack . show @Integer)+ , single (T.pack . show @Scientific)+ , single textAssetPath+ ]+ where+ single :: forall c. (ExprType c) => (c -> Text) -> Maybe (b -> a)+ single conv = listToMaybe $ catMaybes+ [ fromSingle >>= \f -> cast (f . conv)+ , fromList >>= \f -> cast (f . map conv)+ ]++ data ShellExecInfo = ShellExecInfo { seiNode :: Node , seiProcName :: ProcName@@ -108,10 +145,10 @@ handledHandle (KeepHandle h) = h -executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ()-executeCommand ShellExecInfo {..} pstdin pstdout pstderr scmd@ShellCommand {..} = do+executeCommand :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ShellState+executeCommand sei@ShellExecInfo {..} st pstdin pstdout pstderr scmd@ShellCommand {..} = do let args = cmdArguments scmd- ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) cmdExtArguments) $ \cur@( cin, cout, cerr ) -> \case+ ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) (fromShellArguments cmdExtArguments)) $ \cur@( cin, cout, cerr ) -> \case ShellRedirectStdin path -> do closeIfRequested cin h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode@@ -127,59 +164,131 @@ _ -> do return cur - pid <- liftIO $ do- (_, _, _, phandle) <- createProcess_ "shell"- (proc (T.unpack cmdCommand) (map T.unpack args))- { std_in = UseHandle $ handledHandle pstdin'- , std_out = UseHandle $ handledHandle pstdout'- , std_err = UseHandle $ handledHandle pstderr'- , cwd = Just (nodeDir seiNode)- , env = Just []- }- Just pid <- getPid phandle- return pid+ ( getExitStatus, st' ) <- executeCommandProcess sei st (handledHandle pstdin') (handledHandle pstdout') (handledHandle pstderr') args cmdCommand+ let failedWithStatus status = do+ when (shellExitOnError st) $ do+ liftIO $ putMVar seiStatusVar status+ throwError Failed+ return st' { shellLastExitCode = status } mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ]- liftIO (getProcessStatus True False pid) >>= \case- Just (Exited ExitSuccess) -> do- return ()- Just (Exited status) -> do+ getExitStatus >>= \case+ Exited ExitSuccess -> do+ return st' { shellLastExitCode = ExitSuccess }+ Exited status -> do outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine- liftIO $ putMVar seiStatusVar status- throwError Failed- Just (Terminated sig _) -> do+ failedWithStatus status+ Terminated sig _ -> do outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine- liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))- throwError Failed- Just (Stopped sig) -> do+ failedWithStatus (ExitFailure (- fromIntegral sig))+ Stopped sig -> do outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine- liftIO $ putMVar seiStatusVar (ExitFailure (- fromIntegral sig))- throwError Failed- Nothing -> do- outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status"- liftIO $ putMVar seiStatusVar (ExitFailure (- 1))- throwError Failed+ failedWithStatus (ExitFailure (- fromIntegral sig)) -executePipeline :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ()-executePipeline sei pstdin pstdout pstderr ShellPipeline {..} = do++executeCommandProcess :: ShellExecInfo -> ShellState -> Handle -> Handle -> Handle -> [ Text ] -> Text -> TestRun ( TestRun ProcessStatus, ShellState )+executeCommandProcess sei@ShellExecInfo {..} st@ShellState {..} pstdin pstdout pstderr args = \case+ "!"+ | (cmd : args') <- args -> do+ ( exit, st' ) <- executeCommandProcess sei st pstdin pstdout pstderr args' cmd+ let exit' = exit >>= \case Exited ExitSuccess -> return (Exited (ExitFailure (-1)))+ _ -> return (Exited ExitSuccess)+ return ( exit', st' )++ | [] <- args -> do+ return ( return (Exited (ExitFailure (-1))), st )++ "cd"+ | [] <- args -> liftIO $ do+ hPutStrLn pstdout (nodeDir seiNode)+ return ( return (Exited ExitSuccess), st+ { shellWorkingDirectory = nodeDir seiNode+ , shellOldWorkingDirectory = shellWorkingDirectory+ } )+ | [ "-" ] <- args -> liftIO $ do+ hPutStrLn pstdout shellOldWorkingDirectory+ return ( return (Exited ExitSuccess), st+ { shellWorkingDirectory = shellOldWorkingDirectory+ , shellOldWorkingDirectory = shellWorkingDirectory+ } )+ | [ dir ] <- args -> liftIO $ do+ cd <- canonicalizePath $ shellWorkingDirectory </> T.unpack dir+ doesDirectoryExist cd >>= \case+ True -> return ( return (Exited ExitSuccess), st+ { shellWorkingDirectory = cd+ , shellOldWorkingDirectory = shellWorkingDirectory+ } )+ False -> do+ hPutStrLn pstderr $ "cd: no such directory: " <> T.unpack dir+ return ( return (Exited (ExitFailure (-1))), st )+ | otherwise -> do+ liftIO $ hPutStrLn pstderr $ "cd: too many arguments"+ return ( return (Exited (ExitFailure (-1))), st )++ "pwd"+ | [] <- args -> do+ liftIO $ hPutStrLn pstdout shellWorkingDirectory+ return ( return (Exited ExitSuccess), st )+ | otherwise -> do+ liftIO $ hPutStrLn pstderr $ "pwd: too many arguments"+ return ( return (Exited (ExitFailure (-1))), st )++ "set"+ | [ "+e" ] <- args -> do+ return ( return (Exited ExitSuccess), st { shellExitOnError = False } )+ | [ "-e" ] <- args -> do+ return ( return (Exited ExitSuccess), st { shellExitOnError = True } )+ | otherwise -> do+ liftIO $ hPutStrLn pstderr $ "set: " <> T.unpack (T.unwords args) <> ": not implemented"+ return ( return (Exited (ExitFailure (-1))), st )++ cmd -> liftIO $ do+ (_, _, _, phandle) <- createProcess_ "shell"+ (proc (T.unpack cmd) (map T.unpack args))+ { std_in = UseHandle pstdin+ , std_out = UseHandle pstdout+ , std_err = UseHandle pstderr+ , cwd = Just shellWorkingDirectory+ , env = Just []+ }+ Just pid <- getPid phandle+ let getProcessStatus' =+ liftIO (getProcessStatus True False pid) >>= \case+ Just status -> return status+ Nothing -> do+ outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status"+ return (Exited (ExitFailure (-1)))+ return ( getProcessStatus', st )+++executePipeline :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ShellState+executePipeline sei st pstdin pstdout pstderr ShellPipeline {..} = do case pipeUpstream of Nothing -> do- executeCommand sei pstdin pstdout pstderr pipeCommand+ executeCommand sei st pstdin pstdout pstderr pipeCommand Just upstream -> do ( pipeRead, pipeWrite ) <- createPipeCloexec void $ forkTestUsing forkOS $ do- executePipeline sei pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream+ void $ executePipeline sei st pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream - executeCommand sei (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand+ state' <- executeCommand sei st (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand closeIfRequested pstderr+ return state' executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun () executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do setNetworkNamespace $ getNetns seiNode- forM_ statements $ \ShellStatement {..} -> do- executePipeline sei (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline- liftIO $ putMVar seiStatusVar ExitSuccess+ let initialState = ShellState+ { shellWorkingDirectory = nodeDir seiNode+ , shellOldWorkingDirectory = nodeDir seiNode+ , shellExitOnError = True+ , shellLastExitCode = ExitSuccess+ }+ finalState <- (\f -> foldM f initialState statements) $ \st ShellStatement {..} -> do+ executePipeline sei st (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline++ liftIO $ putMVar seiStatusVar (shellLastExitCode finalState) spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process spawnShell procNode procName script = do
src/Script/Var.hs view
@@ -3,6 +3,7 @@ FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, TypedVarName(..), ModuleName(..), textModuleName,+ TestName(..), textTestName, SourceLine(..), textSourceLine, ) where @@ -52,6 +53,17 @@ 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
src/Test.hs view
@@ -25,10 +25,14 @@ import Script.Shell data Test = Test- { testName :: Text+ { testName :: TestName , testTags :: [ Expr Tag ] , testSteps :: Expr (TestStep ()) }++instance ExprType Test where+ textExprType _ = "Test"+ textExprValue _ = "<test>" data Tag = Tag ModuleName VarName deriving (Eq)
src/TestMode.hs view
@@ -4,7 +4,6 @@ testMode, ) where -import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State@@ -23,7 +22,7 @@ import Config import Output import Parser-import Run+import Run.Builtins import Script.Expr import Test @@ -78,8 +77,8 @@ modify $ \s -> s { tmsNextTestNumber = num + 1 } return num -runSingleTest :: Test -> CommandM Bool-runSingleTest test = do+runTestsC :: [ Test ] -> CommandM Report+runTestsC tests = do out <- asks tmiOutput num <- getNextTestNumber Just LoadedModules {..} <- gets tmsModules@@ -88,8 +87,12 @@ { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig , optTestDir = ".test" <> show num , optKeep = True+ , optKeepGoing = True+ , optHookTestResult = \tname res -> do+ flip runReaderT out $ outLine OutputTestRaw Nothing $+ "run-test-result " <> testNameBase tname <> " " <> (if res then "done" else "failed") }- liftIO (runTest out opts lmGlobalDefs test)+ liftIO (runTests out opts lmGlobalDefs tests) newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a)@@ -161,7 +164,11 @@ case filterTests (cfilter <> pfilter) lm of Left err -> showError "run-failed" err Right tests -> do- forM_ tests $ \test -> do- res <- runSingleTest test- cmdOut $ "run-test-result " <> testName test <> " " <> (if res then "done" else "failed")- cmdOut "run-done"+ Report {..} <- runTestsC tests+ cmdOut $ T.unwords+ [ "run-done"+ , T.pack (show reportTotalCount)+ , T.pack (show reportPassedCount)+ , T.pack (show reportSkippedCount)+ , T.pack (show reportFailedCount)+ ]
+ src/TextFormat.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module TextFormat (+ FormattedText,+ plainText,++ TextStyle,+ withStyle, noStyle,++ Color(..),+ setForegroundColor, setBackgroundColor,++ endWithNewline,++ renderPlainText,+ formattedTextLength,+ formattedTextHeight,+) where++import Data.Text (Text)+import Data.Text qualified as T++import TextFormat.Types+++plainText :: Text -> FormattedText+plainText = PlainText+++withStyle :: TextStyle -> FormattedText -> FormattedText+withStyle = FormattedText++noStyle :: TextStyle+noStyle = CustomTextColor Nothing Nothing++setForegroundColor :: Color -> TextStyle -> TextStyle+setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg++setBackgroundColor :: Color -> TextStyle -> TextStyle+setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color)+++endWithNewline :: FormattedText -> FormattedText+endWithNewline = EndWithNewline+++renderPlainText :: FormattedText -> Text+renderPlainText = \case+ PlainText text -> text+ ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts+ FormattedText _ ftext -> renderPlainText ftext+ EndWithNewline ftext -> let res = renderPlainText ftext+ in case T.unsnoc res of+ Just ( _, '\n') -> res+ _ -> res <> "\n"++formattedTextLength :: FormattedText -> Int+formattedTextLength = \case+ PlainText text -> T.length text+ ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts+ FormattedText _ ftext -> formattedTextLength ftext+ EndWithNewline ftext -> formattedTextLength ftext++formattedTextHeight :: FormattedText -> Int+formattedTextHeight = countLines . collectParts+ where+ collectParts = \case+ PlainText text -> [ text ]+ ConcatenatedText ftexts -> concatMap collectParts ftexts+ FormattedText _ ftext -> collectParts ftext+ EndWithNewline ftext -> collectParts ftext+ countLines (t : ts)+ | T.null t = countLines ts+ | otherwise = 1 + countLines (dropLine (t : ts))+ countLines [] = 0+ dropLine (t : ts)+ | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts+ | otherwise = dropLine ts+ dropLine [] = []
+ src/TextFormat/Ansi.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module TextFormat.Ansi (+ FormattedText,++ AnsiText(..),+ renderAnsiText,+) where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Writer++import Data.String+import Data.Text (Text)+import Data.Text qualified as T++import TextFormat.Types+++newtype AnsiText = AnsiText { fromAnsiText :: Text }+ deriving (Eq, Ord, Semigroup, Monoid, IsString)+++data RenderState = RenderState+ { rsEndedWithNewline :: Bool+ }++initialRenderState :: RenderState+initialRenderState = RenderState+ { rsEndedWithNewline = True+ }++renderAnsiText :: FormattedText -> AnsiText+renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft+ where+ go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) ()+ go cur@( cfg, cbg ) = \case+ PlainText text -> do+ tell [ text ]+ case T.unsnoc text of+ Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' })+ Nothing -> return ()+ ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts+ FormattedText (CustomTextColor fg bg) ftext -> do+ tell [ ansiColor fg bg ]+ go ( fg <|> cfg, bg <|> cbg ) ftext+ tell [ ansiColor+ (if fg /= cfg then cfg <|> Just DefaultColor else Nothing)+ (if bg /= cbg then cbg <|> Just DefaultColor else Nothing)+ ]+ EndWithNewline ftext -> do+ go cur ftext+ gets rsEndedWithNewline >>= \case+ True -> return ()+ False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True })+++ansiColor :: Maybe Color -> Maybe Color -> Text+ansiColor Nothing Nothing = ""+ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m"+ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m"+ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m"++colorNum :: Color -> Int+colorNum = \case+ DefaultColor -> 39+ Black -> 30+ Red -> 31+ Green -> 32+ Yellow -> 33+ Blue -> 34+ Magenta -> 35+ Cyan -> 36+ White -> 37+ BrightBlack -> 90+ BrightRed -> 91+ BrightGreen -> 92+ BrightYellow -> 93+ BrightBlue -> 94+ BrightMagenta -> 95+ BrightCyan -> 96+ BrightWhite -> 97
+ src/TextFormat/Types.hs view
@@ -0,0 +1,58 @@+module TextFormat.Types (+ FormattedText(..),+ TextStyle(..),+ Color(..),+) where++import Data.String+import Data.Text (Text)+++data FormattedText+ = PlainText Text+ | ConcatenatedText [ FormattedText ]+ | FormattedText TextStyle FormattedText+ | EndWithNewline FormattedText++instance IsString FormattedText where+ fromString = PlainText . fromString++instance Semigroup FormattedText where+ ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys)+ x <> ConcatenatedText ys = ConcatenatedText (x : ys)+ ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ])+ x <> y = ConcatenatedText [ x, y ]++instance Monoid FormattedText where+ mempty = ConcatenatedText []+ mconcat [] = ConcatenatedText []+ mconcat [ x ] = x+ mconcat xs = ConcatenatedText $ concatMap flatten xs+ where+ flatten (ConcatenatedText ys) = ys+ flatten y = [ y ]+++data TextStyle+ = CustomTextColor (Maybe Color) (Maybe Color)+++data Color+ = DefaultColor+ | Black+ | Red+ | Green+ | Yellow+ | Blue+ | Magenta+ | Cyan+ | White+ | BrightBlack+ | BrightRed+ | BrightGreen+ | BrightYellow+ | BrightBlue+ | BrightMagenta+ | BrightCyan+ | BrightWhite+ deriving (Eq)