deft test: new subcommand

documentation/source/index.rst

@@ -716,6 +716,44 @@ Synopsis: ``deft status``
       pacman-catalog           : ## publish...master [ahead 1] (dirty)
 
 
+.. index::
+   single: deft test subcommand
+   single: subcommand; deft test
+
+deft test
+---------
+
+Run tests for packages in the current workspace.
+
+Synopsis: ``deft test [options] [library ...] [--] [...testworks-options...]``
+
+`deft test`_ determines which test binaries to run by choosing the first option below
+that is not empty.
+
+1. Library names that are passed on the command line.
+2. The library specified by ``"default-test-library"`` in the :file:`workspace.json`
+   file.
+3. Any executable test libraries in the workspace's active packages.
+4. Any non-executable test libraries in the workspace's active packages.
+
+Executable test libraries are invoked directly (it is assumed that they call
+`run-test-application`_) and non-executable test libraries are run via `testworks-run`_.
+Any options following ``--`` on the command line are passed to the test executable or
+`testworks-run`_.
+
+If any test run fails `deft test`_ exits immediately with a failure status without
+running the tests in the remaining libraries.
+
+**Options:**
+
+``--build``
+  Rebuild test libraries before running the tests. The default is not to rebuild.
+
+``--continue``
+  If a test binary fails, continue running the remaining test binaries instead of
+  exiting immediately with a failure status.
+
+
 .. index::
    single: deft update subcommand
    single: deft subcommand; update

dylan-package.json

@@ -7,7 +7,7 @@
     "description": "Manage Dylan workspaces, packages, and registries",
     "keywords": ["workspace", "package"],
     "dependencies": [
-        "command-line-parser@3.1.1",
+        "command-line-parser@3.2.2",
         "[email protected]",
         "[email protected]",
         "[email protected]",

sources/commands/build.dylan

@@ -98,7 +98,7 @@ end function;
 define function active-package-libraries
     (ws :: ws/<workspace>) => (libraries :: <seq>)
   collecting ()
-    for (lids in ws/lids-by-active-package(ws))
+    for (lids in ws/lids-by-release(ws))
       for (lid in lids)
         collect(ws/library-name(lid));
       end;

sources/commands/command-line.dylan

@@ -30,8 +30,9 @@ define function deft-command-line
                    subcommands: list($new-application-subcommand,
                                      $new-library-subcommand,
                                      $new-workspace-subcommand)),
-              $update-subcommand,
-              $status-subcommand,
               $publish-subcommand,
+              $status-subcommand,
+              $test-subcommand,
+              $update-subcommand,
               $version-subcommand))
 end function;

sources/commands/test.dylan

@@ -0,0 +1,149 @@
+Module: deft
+Synopsis: test subcommand
+
+// The deft test subcommand builds test libraries and runs the tests.  It uses heuristics
+// on the library name to figure out which libraries are test libraries (see
+// test-library-name?).
+
+// Some workspaces (especially multi-package libraries) may have both test executables
+// (e.g., foo-test-app) and test shared libraries.  In that case we only run the
+// executables, on the assumption that they will take care of running all the tests.
+// Otherwise it could result in running some tests multiple times.
+
+// If any test run fails `deft test` exits immediately with a failure status without
+// running the tests in the remaining libraries.
+
+
+define class <test-subcommand> (<new-subcommand>)
+  keyword name = "test";
+  keyword help = "Run tests for workspace packages.";
+end class;
+
+define constant $test-subcommand
+  = make(<test-subcommand>,
+         options:
+           list(make(<flag-option>,
+                     names: #("all", "a"),
+                     help: "Also run tests for dependencies. [false]"),
+                make(<flag-option>,
+                     names: #("continue", "c"),
+                     help: "Continue running test binaries even after one fails. [false]"),
+                make(<flag-option>,
+                     names: #("build", "b"),
+                     help: "Rebuild test binaries before running them. [false]"),
+                make(<positional-option>,
+                     names: #("libraries"),
+                     help: "Libraries to test, optionally followed by '--' and Testworks options.",
+                     repeated?: #t,
+                     required?: #f)));
+
+define method execute-subcommand
+    (parser :: <command-line-parser>, subcmd :: <test-subcommand>)
+ => (status :: false-or(<int>))
+  // TODO: warn if a library specified on the command line wasn't found in any package.
+  let exit-status = 0;
+  let build? = get-option-value(subcmd, "build");
+  let all? = get-option-value(subcmd, "all");
+  let libraries = get-option-value(subcmd, "libraries") | #();
+  local
+    method is-exe-library? (lid)
+      #"executable" == as(<symbol>, ws/lid-value(lid, #"target-type") | "")
+    end,
+    method filter-to-command-line-libraries (lids)
+      choose(method (lid)
+               empty?(libraries)
+                 | member?(ws/library-name(lid), libraries, test: \=)
+             end,
+             lids)
+    end;
+  block (return)
+    let ws = ws/load-workspace();
+    let lid-map = ws/find-active-package-test-libraries(ws, all?);
+    if (lid-map.empty?)
+      warn("No libraries found in workspace? No tests to run.");
+      return(1);
+    end;
+    let exes = #();
+    let dlls = #();
+    for (lids keyed-by release in lid-map)
+      let lids = filter-to-command-line-libraries(lids);
+      let _exes = choose(is-exe-library?, lids);
+      if (empty?(_exes))
+        // Only build DLL tests for this package if there are no EXE tests.
+        // Assume the exe tests include the dlls.
+        let _dlls = choose(complement(is-exe-library?), lids);
+        if (_dlls.empty?)
+          warn("No tests found for package %s.", release.pm/package-name);
+        end;
+        dlls := concat(dlls, _dlls);
+      else
+        exes := concat(exes, _exes);
+      end;
+    end for;
+    let ws-dir = ws/workspace-directory(ws);
+    if (build?)
+      do(rcurry(build-library, "executable", ws-dir), exes);
+      ~empty?(dlls) & build-testworks-run(ws-dir);
+      do(rcurry(build-library, "dll", ws-dir), dlls);
+    end;
+    local method run-test (lid :: ws/<lid>, exe?)
+            let library = ws/library-name(lid);
+            let binary = ws/lid-value(lid, #"executable") | library;
+            let build-dir = ws/build-directory(ws);
+            let testworks-options = subcmd.unconsumed-arguments; // args after "--"
+            let command
+              = if (exe?)
+                  let exe-path = as(<string>, file-locator(build-dir, "bin", binary));
+                  if (~fs/file-exists?(exe-path))
+                    note("Building test %s (no binary found)", library);
+                    build-library(lid, "executable", ws-dir);
+                  end;
+                  apply(vector, exe-path, testworks-options)
+                else
+                  let extension = select (os/$os-name)
+                                    #"win32" => ".dll";
+                                    #"darwin" => ".dylib";
+                                    otherwise => ".so";
+                                  end;
+                  let lib-name = concat("lib", binary, extension);
+                  let exe-path = as(<string>, file-locator(build-dir, "bin", "testworks-run"));
+                  apply(vector, exe-path, "--load", lib-name, testworks-options)
+                end;
+            let status = os/run-application(command, under-shell?: #f, working-directory: ws-dir);
+            if (status ~== 0)
+              warn("Test library %s failed with exit status %=.", lid.ws/library-name, status);
+              if (~get-option-value(subcmd, "continue"))
+                return(1);
+              end;
+              exit-status := 1;
+            end;
+          end method;
+    do(rcurry(run-test, #t), exes);
+    do(rcurry(run-test, #f), dlls);
+  end block;
+  exit-status
+end method execute-subcommand;
+
+define method build-library
+    (lid :: ws/<lid>, target-type :: <string>, dir :: <directory-locator>)
+  build-library(lid.ws/library-name, target-type, dir)
+end method;
+
+define method build-library
+    (library :: <string>, target-type :: <string>, dir :: <directory-locator>)
+  let command = join(list("dylan-compiler", "-build", "-target", target-type, library), " ");
+  let status = os/run-application(command, under-shell?: #t, working-directory: dir);
+  if (status ~== 0)
+    warn("Error building library %s:", library);
+  end;
+end method;
+
+define variable *testworks-run-built?* = #f;
+
+define function build-testworks-run
+    (ws-dir :: <directory-locator>) => ()
+  if (~*testworks-run-built?*)
+    *testworks-run-built?* := #t;
+    build-library("testworks-run", "executable", ws-dir);
+  end;
+end function;

sources/deft.lid

@@ -18,6 +18,7 @@ Files: library.dylan
        commands/new-workspace.dylan
        commands/publish.dylan
        commands/status.dylan
+       commands/test.dylan
        commands/update.dylan
        commands/utils.dylan
        commands/version.dylan

sources/library.dylan

@@ -26,25 +26,25 @@ end library;
 
 // Utilities shared by all Deft modules, and also a set of shared imports.
 define module deft-shared
-  use collectors, export: all;
+  use collectors,          export: all;
   use command-line-parser, export: all;
-  use date, import: { current-date, <duration> }, export: all;
-  use dylan-extensions, import: { address-of }, export: all;
-  use file-source-records, prefix: "sr/", export: all;
-  use file-system, prefix: "fs/", export: all;
-  use format-out, export: all;
-  use format, export: all;
-  use json, export: all;
-  use locators, export: all;
-  use operating-system, prefix: "os/", export: all;
-  use print, export: all;
+  use date,                export: all, import: { current-date, <duration> };
+  use dylan-extensions,    export: all, import: { address-of };
+  use file-source-records, export: all, prefix: "sr/";
+  use file-system,         export: all, prefix: "fs/";
+  use format-out,          export: all;
+  use format,              export: all;
+  use json,                export: all;
+  use locators,            export: all;
+  use operating-system,    export: all, prefix: "os/";
+  use print,               export: all;
   use regular-expressions, export: all;
-  use standard-io, export: all;
-  use streams, export: all;
-  use strings, export: all;
-  use threads, import: { dynamic-bind }, export: all;
-  use uncommon-dylan, export: all;
-  use uncommon-utils, export: all;
+  use standard-io,         export: all;
+  use streams,             export: all;
+  use strings,             export: all;
+  use threads,             export: all, import: { dynamic-bind };
+  use uncommon-dylan,      export: all;
+  use uncommon-utils,      export: all;
 
   export
     *debug?*,
@@ -149,15 +149,20 @@ define module workspaces
     active-package-directory,
     active-package-file,
     active-package?,
+    build-directory,
     current-dylan-package,
     ensure-deps-installed,
+    find-active-package-test-libraries,
     find-dylan-package-file,
     find-workspace-directory,
     find-workspace-file,
     library-name,
-    lids-by-active-package,
+    <lid>,
+    lid-value,
+    lid-values,
     lids-by-library,
     lids-by-pathname,
+    lids-by-release,
     load-workspace,
     registry-directory,
     update-registry,
@@ -171,15 +176,13 @@ define module %workspaces
   use workspaces;
   use pacman,
     prefix: "pm/",
-    // Because / followed by * is seen as a comment by dylan-mode.
+    // Because pm/*... is seen as a /* comment by dylan-mode.
     rename: { *package-manager-directory* => *package-manager-directory* };
 
   // Exports for the test suite.
   export
     $lid-key,
     lid-data,
-    lid-value,
-    lid-values,
     parse-lid-file;
 end module;
 

sources/workspaces/lid.dylan

@@ -49,8 +49,8 @@ define function lid-value
 end function;
 
 define function library-name
-    (lid :: <lid>) => (name :: false-or(<string>))
-  lid-value(lid, $library-key, error?: #f)
+    (lid :: <lid>, #key error? :: <bool>) => (name :: false-or(<string>))
+  lid-value(lid, $library-key, error?: error?)
 end function;
 
 // Return the transitive (via files included with the "LID" header) contents of
@@ -78,21 +78,34 @@ define function dylan-source-files
   files
 end function;
 
+define function matches-current-platform?
+    (lid :: <lid>) => (matches? :: <bool>)
+  let current-platform = as(<string>, os/$platform-name);
+  let platform = lid-value(lid, $platforms-key);
+  // Assume that if the LID is included in another LID then it contains the
+  // platform-independent attributes of a multi-platform project and is not a top-level
+  // library.
+  platform = current-platform
+    | (~platform & lid.library-name & empty?(lid.lid-included-in))
+end function;
+
 define function add-lid
     (ws :: <workspace>, active-package :: false-or(pm/<release>), lid :: <lid>)
  => ()
-  let library-name = lid-value(lid, $library-key);
-  if (library-name)
-    let lids = element(ws.%lids-by-library, library-name, default: #());
-    if (member?(lid, lids))
-      debug("Re-adding %s, all lids for this library: %=", lid, lids);
+  if (matches-current-platform?(lid))
+    let library = lid-value(lid, $library-key);
+    if (library)
+      let lids = element(ws.%lids-by-library, library, default: #());
+      if (member?(lid, lids))
+        debug("Re-adding %s, all lids for this library: %=", lid, lids);
+      end;
+      ws.%lids-by-library[library] := pair(lid, lids);
+    end;
+    ws.%lids-by-pathname[as(<string>, lid.lid-locator)] := lid;
+    if (active-package)
+      let lids = element(ws.%lids-by-release, active-package, default: #());
+      ws.%lids-by-release[active-package] := pair(lid, lids);
     end;
-    ws.%lids-by-library[library-name] := pair(lid, lids);
-  end;
-  ws.%lids-by-pathname[as(<string>, lid.lid-locator)] := lid;
-  if (active-package)
-    let lids = element(ws.%lids-by-active-package, active-package, default: #());
-    ws.%lids-by-active-package[active-package] := pair(lid, lids);
   end;
 end function;