Merge pull request #58 from cgay/local-packages

Local packages

commands/simple-commands.dylan

@@ -150,12 +150,17 @@ define class <update-subcommand> (<subcommand>)
 end class;
 
 define constant $update-subcommand
-  = make(<update-subcommand>);
+  = make(<update-subcommand>,
+         options: list(make(<flag-option>,
+                            names: #("global"),
+                            help: "Install packages in ${DYLAN}/pkg instead of in the"
+                              " workspace.")));
 
 define method execute-subcommand
     (parser :: <command-line-parser>, subcmd :: <update-subcommand>)
  => (status :: false-or(<int>))
-  ws/update();
+  let global? = get-option-value(subcmd, "global");
+  ws/update(global?: global?);
 end method;
 
 

documentation/source/index.rst

@@ -647,26 +647,29 @@ you're satisfied that you're ready to release a new version of your package
 (tests pass, doc updated, etc.) follow these steps:
 
 #.  Update the ``"version"`` attribute in :file:`dylan-package.json` to be the
-    new release's version, commit the change, and push it to your main branch.
+    new release's version.
 
-#.  Update any dependencies in :file:`dylan-package.json` as needed. Normally
-    this will happen naturally during development as you discover you need
-    newer package versions, but this is a good time to review deps and update
-    to get bug fixes if desired.  **Remember to** `dylan update`_ **and re-run
-    your tests if you change deps!**
+    Also update any dependencies as needed. Normally this will happen naturally
+    during development as you discover you need newer package versions, but
+    this is a good time to review deps and update to get bug fixes if desired.
+    **Remember to** `dylan update`_ **and re-run your tests if you change
+    deps!**
+
+    Push the above changes (if any) to your main branch.
 
 #.  Make a new release on GitHub with a tag that matches the release version.
     For example, if the ``"version"`` attribute in :file:`dylan-package.json`
     is ``"0.5.0"`` the GitHub release should be tagged ``v0.5.0``.
 
-#.  Clone https://github.com/dylan-lang/pacman-catalog somewhere.  In the next
-    step the `dylan publish`_ command will make changes there for you.
+#.  Clone https://github.com/dylan-lang/pacman-catalog somewhere and create a
+    new branch named after your package.  In the next step the `dylan publish`_
+    command will make changes there for you.
 
     If you had already cloned pacman-catalog, **make sure to pull the latest
     changes.**
 
 #.  Run :command:`dylan publish /path/to/pacman-catalog`, pointing to where you
-    just cloned the pacman-catalog.
+    just cloned the pacman catalog.
 
 #.  Commit the changes to `pacman-catalog`_ and submit a pull request.  The
     tests to verify the catalog will be run automatically by the GitHub CI.
@@ -675,10 +678,6 @@ you're satisfied that you're ready to release a new version of your package
     catalog by running :command:`dylan install [email protected]`, substituting
     your new package name and release version.
 
-#.  It's generally good practice to update the version immediately after
-    publishing a release so that it reflects the *next* release's version
-    number. See :ref:`package-versions` for more on this.
-
 
 .. index::
    single: dylan status subcommand
@@ -744,10 +743,9 @@ performs two actions:
     If a dependency is also an active package in this workspace, the active
     package is preferred over the specific version listed as a dependency.
 
-    .. note:: Registry files are only created if they apply to the architecture
-       of the local machine. For example, on ``x86_64-linux`` LID files that
-       specify ``Platforms: win32`` will not cause a registry file to be
-       generated.
+.. note:: Registry files are only created if they apply to the platform of the
+   local machine. For example, on the ``x86_64-linux`` platform LID files that
+   specify ``Platforms: win32`` will not cause a registry file to be generated.
 
 Example:
 ~~~~~~~~

dylan-package.json

@@ -13,6 +13,7 @@
         "[email protected]"
     ],
     "dev-dependencies": [
+        "sphinx-extensions",
         "[email protected]"
     ],
     "url": "https://github.com/dylan-lang/dylan-tool"

library.dylan

@@ -5,7 +5,7 @@ define library dylan-tool
     import: { table-extensions };
   use command-line-parser;
   use dylan,
-    import: { dylan-extensions };
+    import: { dylan-extensions, threads };
   use io,
     import: { format, format-out, print, standard-io, streams };
   use json;
@@ -49,6 +49,8 @@ define module pacman
     <catalog-error>,
     catalog,
     dylan-directory,            // $DYLAN or $HOME/dylan or /opt/dylan
+    package-manager-directory,
+    *package-manager-directory*,
 
     <catalog>,
     catalog-directory,
@@ -171,20 +173,24 @@ end module;
 define module %workspaces
   use dylan-extensions,
     import: { address-of };
+  use file-source-records, prefix: "sr/";
   use file-system, prefix: "fs/";
   use format;
   use format-out;
   use json;
   use locators;
   use operating-system, prefix: "os/";
-  use pacman, prefix: "pm/";
+  use pacman,
+    prefix: "pm/",
+    // Because / followed by * is seen as a comment by dylan-mode.
+    rename: { *package-manager-directory* => *package-manager-directory* };
   use print;
   use regular-expressions;
   use shared;
-  use file-source-records, prefix: "sr/";
   use standard-io;
   use streams;
   use strings;
+  use threads;
   use uncommon-dylan,
     exclude: { format-to-string };
   use uncommon-utils,

pacman/install.dylan

@@ -1,22 +1,24 @@
 Module: %pacman
 Synopsis: Package download and installation
 
-// TODO:
-//  * wrap libgit2 instead of shelling out to git.
-//  * ^^ or not. Perhaps it doesn't really make sense to use arbitrary
-//    URLs as the package location. That likely requires every user to
-//    have access credentials for all the servers those URLs point to.
-//    It's probably necessary to have a single location (with mirrors)
-//    into which we stuff a tarball or zip file. What do other package
-//    managers do?
 
 define constant $source-directory-name = "src";
 
-// Directory in which all versions of a package are installed.
-define not-inline function package-directory
-    (pkg-name :: <string>) => (_ :: <directory-locator>)
+// Directory in which to find or install packages. This depends on the value of
+// *package-manager-directory*, which may be dynamically bound.
+define generic package-directory
+    (package :: <object>) => (directory :: <directory-locator>);
+
+define method package-directory
+    (pkg-name :: <string>) => (directory :: <directory-locator>)
   subdirectory-locator(package-manager-directory(), lowercase(pkg-name))
-end function;
+end method;
+
+define method package-directory
+    (package :: type-union(<package>, <release>))
+ => (directory :: <directory-locator>)
+  package-directory(package-name(package))
+end method;
 
 // Directory in which a specific release is installed.
 define not-inline function release-directory
@@ -66,8 +68,7 @@ define method %download
     = format-to-string("git clone%s --quiet --branch=%s -- %s %s",
                        (update-submodules? & " --recurse-submodules") | "",
                        branch, release.release-url, dest-dir);
-  let (exit-code, signal-code /* , process, #rest streams */)
-    = os/run-application(command, output: #"null", error: #"null");
+  let exit-code = os/run-application(command, output: #"null", error: #"null");
   if (exit-code = 0)
     note("Downloaded %s to %s", release, dest-dir);
   else
@@ -76,6 +77,57 @@ define method %download
   end;
 end method;
 
+// Make sure the "current" link from `release`s package directory to
+// `target-dir` is up to date.
+define function ensure-current-link
+    (release :: <release>, target-dir :: <directory-locator>) => ()
+  let link-source = merge-locators(as(<file-locator>, "current"),
+                                   package-directory(release-package(release)));
+  // Use file-type instead of file-exists? because the latter would follow the link.
+  // After https://github.com/dylan-lang/opendylan/pull/1484 is in an OD release
+  // (i.e., post 2022.1) this can use file-exists?(link-source, follow-links?: #f).
+  let exists? = block ()
+                  fs/file-type(link-source)
+                exception (fs/<file-system-error>)
+                  #f
+                end;
+  let target = as(<string>, release-directory(release));
+  if (ends-with?(target, "/") | ends-with?(target, "\\"))
+    target := copy-sequence(target, end: target.size - 1);
+  end;
+  let existing-target = exists? & fs/link-target(link-source);
+  if (exists? & (target ~= as(<string>, existing-target)))
+    debug("Deleting %s", link-source);
+    fs/delete-file(link-source);
+    exists? := #f;
+  end;
+  if (~exists?)
+    debug("Creating symlink %s -> %s", link-source, target);
+    create-symbolic-link(target, link-source);
+  end;
+end function;
+
+// TODO(cgay): TEMPORARY -- Need to add create-symbolic-link to the system library
+// but for now this allows me to move forward.
+define function create-symbolic-link
+    (target :: fs/<pathname>, link-name :: fs/<pathname>)
+  let command
+    = if (os/$os-name == #"win32")
+        vector("mklink", "/D", link-name, target) // untested
+      else
+        vector("/bin/ln", "--symbolic",
+               as(<byte-string>, target),
+               as(<byte-string>, link-name))
+      end;
+  let exit-code
+    = os/run-application(command, under-shell?: #f, output: #"null", error: #"null");
+  if (exit-code ~= 0)
+    package-error("failed to create 'current' link for package."
+                    " Exit code %d. The command was: %s",
+                  exit-code, join(command, " "));
+  end;
+end function;
+
 // Download and install `release` into the standard location.
 //
 // Parameters:
@@ -103,12 +155,22 @@ define method install
     debug("Deleting package %s for forced install.", release);
     fs/delete-directory(release-directory(release), recursive?: #t);
   end;
-  if (installed?(release))
-    debug("Package %s is already installed.", release);
-  else
-    download(release, source-directory(release));
-    #t
-  end
+  let dest-dir = source-directory(release);
+  block ()
+    if (installed?(release))
+      debug("Package %s is already installed.", release);
+      #f
+    else
+      download(release, dest-dir);
+      #t
+    end
+  cleanup
+    // Update current link even if download not needed, in case user is
+    // updating to a previously installed version. (Might not want to update
+    // the link for global installations, but it shouldn't hurt, and I might do
+    // away with global installations altogether so ignoring it for now.)
+    ensure-current-link(release, dest-dir);
+  end block
 end method;
 
 // Install dependencies of `release`. If `force?` is true, remove and

pacman/utils.dylan

@@ -3,15 +3,21 @@ Module: %pacman
 // This enables the #:string: prefix to "parse" raw string literals.
 define function string-parser (s :: <string>) => (s :: <string>) s end;
 
-// Name of the directory under $DYLAN where installed versions are stored.
+// Name of the subdirectory in which packages are to be installed.
 define constant $package-directory-name = "pkg";
 
-// Exported
+// This provides a way for dylan-tool commands to override the default package
+// installation directory without threading it through the entire call chain,
+// so that (for example) package installations can be local to a workspace
+// rather than global. (In the long run, do we even want global installations?)
+define thread variable *package-manager-directory* :: false-or(<directory-locator>) = #f;
+
 // The package manager will never modify anything outside this directory unless
 // explicitly requested (e.g., via a directory passed to download).
 define function package-manager-directory
     () => (dir :: <directory-locator>)
-  subdirectory-locator(dylan-directory(), $package-directory-name)
+  *package-manager-directory*
+    | subdirectory-locator(dylan-directory(), $package-directory-name)
 end function;
 
 // TODO: Windows

workspaces/workspaces.dylan

@@ -68,25 +68,32 @@ end function;
 
 // Update the workspace based on the workspace.json file or signal an error.
 define function update
-    (#key directory :: <directory-locator> = fs/working-directory())
+    (#key directory :: <directory-locator> = fs/working-directory(),
+          global? :: <bool>)
  => ()
   let ws = load-workspace(directory: directory);
   let cat = pm/catalog();
-  let (releases, actives) = update-deps(ws, cat);
-  let registry = update-registry(ws, cat, releases, actives);
-
-  let no-lid = registry.libraries-with-no-lid;
-  if (~empty?(no-lid) & *verbose?*)
-    warn("These libraries had no LID file for platform %s:\n  %s",
-         os/$platform-name, join(sort!(no-lid), ", "));
-  end;
+  dynamic-bind (*package-manager-directory*
+                  = if (global?)
+                      *package-manager-directory*
+                    else
+                      subdirectory-locator(workspace-directory(ws), "_packages")
+                    end)
+    let (releases, actives) = update-deps(ws, cat);
+    let registry = update-registry(ws, cat, releases, actives);
+    let no-lid = registry.libraries-with-no-lid;
+    if (~empty?(no-lid) & *verbose?*)
+      warn("These libraries had no LID file for platform %s:\n  %s",
+           os/$platform-name, join(sort!(no-lid), ", "));
+    end;
 
-  let reg-dir = subdirectory-locator(registry.root-directory, "registry");
-  let num-files = registry.num-files-written;
-  if (num-files == 0)
-    note("Registry %s is up-to-date.", reg-dir);
-  else
-    note("Updated %d files in %s.", registry.num-files-written, reg-dir);
+    let reg-dir = subdirectory-locator(registry.root-directory, "registry");
+    let num-files = registry.num-files-written;
+    if (num-files == 0)
+      note("Registry %s is up-to-date.", reg-dir);
+    else
+      note("Updated %d files in %s.", registry.num-files-written, reg-dir);
+    end;
   end;
 end function;