From 0a03eb133bd7015ad72e62af2debe1af984b3662 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Tue, 17 Dec 2024 17:53:14 -0500 Subject: [PATCH 01/12] cleanup: use new file-locator and file-exists?(f, follow-links?: #f) --- sources/commands/build.dylan | 1 + sources/commands/new-library.dylan | 16 +++++--------- sources/pacman/catalog.dylan | 9 ++++---- sources/pacman/install-test.dylan | 6 ++--- sources/pacman/install.dylan | 12 ++-------- sources/workspaces/registry-test.dylan | 6 ++--- sources/workspaces/registry.dylan | 28 ++++++++++-------------- sources/workspaces/workspaces-test.dylan | 7 +++--- sources/workspaces/workspaces.dylan | 23 +++++++++---------- 9 files changed, 40 insertions(+), 68 deletions(-) diff --git a/sources/commands/build.dylan b/sources/commands/build.dylan index 4e3747a..a90d6f8 100644 --- a/sources/commands/build.dylan +++ b/sources/commands/build.dylan @@ -57,6 +57,7 @@ define method execute-subcommand end; let dylan-compiler = locate-dylan-compiler(); for (name in library-names) + // TODO: this should pass -target dll in some cases. let command = remove(vector(dylan-compiler, "-compile", get-option-value(subcmd, "clean") & "-clean", diff --git a/sources/commands/new-library.dylan b/sources/commands/new-library.dylan index 1df55f3..bd93762 100644 --- a/sources/commands/new-library.dylan +++ b/sources/commands/new-library.dylan @@ -336,17 +336,11 @@ end function; define function make-dylan-library (name :: , dir :: , exe? :: , deps :: , force-package? :: , simple? :: ) - local - method file (name) - merge-locators(as(, name), dir) - end, - method test-file (name) - merge-locators(as(, name), - subdirectory-locator(dir, "tests")) - end, - method dep-string (dep) - format-to-string("%=", pm/dep-to-string(dep)) - end; + local method dep-string (dep) + format-to-string("%=", pm/dep-to-string(dep)) + end; + let file = curry(file-locator, dir); + let test-file = curry(file-locator, dir, "tests"); let test-name = concat(name, "-test-suite"); let deps-string = join(map-as(, dep-string, deps), ", "); let base-library-templates diff --git a/sources/pacman/catalog.dylan b/sources/pacman/catalog.dylan index b705254..c6a1e63 100644 --- a/sources/pacman/catalog.dylan +++ b/sources/pacman/catalog.dylan @@ -127,9 +127,7 @@ define function load-all-catalog-packages #"directory" => fs/do-directory(load-one, subdirectory-locator(dir, name)); #"file" => - // TODO: in release after 2020.1 use file-locator here. - let file = merge-locators(as(, name), dir); - add!(packages, load-catalog-package-file(cat, name, file)); + add!(packages, load-catalog-package-file(cat, name, file-locator(dir, name))); end; end method; fs/do-directory(load-one, cat.catalog-directory); @@ -254,10 +252,11 @@ define method package-locator 1 => subdirectory-locator(root, "1"); 2 => subdirectory-locator(root, "2"); otherwise => - subdirectory-locator(subdirectory-locator(root, copy-sequence(name, end: 2)), + subdirectory-locator(root, + copy-sequence(name, end: 2), copy-sequence(name, start: 2, end: min(4, name.size))) end; - merge-locators(as(, name), dir) + file-locator(dir, name) end method; // The JSON printer calls do-print-json. We convert most objects to tables, diff --git a/sources/pacman/install-test.dylan b/sources/pacman/install-test.dylan index b8aaa4f..995d8b6 100644 --- a/sources/pacman/install-test.dylan +++ b/sources/pacman/install-test.dylan @@ -18,10 +18,8 @@ define test test-install (tags: #["net"]) assert-false(installed?(release)); install(release); assert-true(installed?(release)); - let file = as(, - format-to-string("%s/json/1.0.0/src/json.lid", - $package-directory-name)); - let lid-path = merge-locators(file, dir); + let lid-path + = file-locator(dir, $package-directory-name, "json", "1.0.0", "src", "json.lid"); assert-true(file-exists?(lid-path)); let versions = installed-versions(release.package-name); assert-equal(1, size(versions)); diff --git a/sources/pacman/install.dylan b/sources/pacman/install.dylan index 06412b4..5bd45ce 100644 --- a/sources/pacman/install.dylan +++ b/sources/pacman/install.dylan @@ -81,16 +81,8 @@ end method; // `target-dir` is up to date. define function ensure-current-link (release :: , target-dir :: ) => () - let link-source = merge-locators(as(, "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/) - #f - end; + let link-source = file-locator(package-directory(release-package(release)), "current"); + let exists? = fs/file-exists?(link-source, follow-links?: #f); let target = as(, release-directory(release)); if (ends-with?(target, "/") | ends-with?(target, "\\")) target := copy-sequence(target, end: target.size - 1); diff --git a/sources/workspaces/registry-test.dylan b/sources/workspaces/registry-test.dylan index 4539ef1..c7fceb7 100644 --- a/sources/workspaces/registry-test.dylan +++ b/sources/workspaces/registry-test.dylan @@ -30,8 +30,7 @@ define test test-source-file-map--basics () // Note that the "library" file intentionally has no ".dylan" extension, and // the extension is expected to be added in the map keys. for (filename in #("library.dylan", "foo.dylan")) - let full-locator - = merge-locators(as(, filename), directory); + let full-locator = file-locator(directory, filename); let full-path = as(, full-locator); assert-equal(#("foo"), element(file-map, full-path, default: #f), @@ -58,8 +57,7 @@ define test test-source-file-map--included-lid () #(#("abc", "abc-test-suite"), "a.dylan", "b.dylan", "c.dylan"))) let (libraries, #rest filenames) = apply(values, item); for (filename in filenames) - let full-locator - = merge-locators(as(, filename), directory); + let full-locator = file-locator(directory, filename); let full-path = as(, full-locator); assert-equal(sort(libraries), sort(element(file-map, full-path, default: #())), diff --git a/sources/workspaces/registry.dylan b/sources/workspaces/registry.dylan index 7458970..61b23e0 100644 --- a/sources/workspaces/registry.dylan +++ b/sources/workspaces/registry.dylan @@ -77,7 +77,7 @@ define function registry-file-locator // The registry file must be written in lowercase so that on unix systems the // compiler can find it. let lib = lowercase(lid-value(lid, $library-key, error?: #t)); - merge-locators(as(, lib), directory) + file-locator(directory, lib) end function; @@ -142,9 +142,8 @@ define function dylan-source-files (lid :: ) => (files :: ) if (~ends-with?(lowercase(filename), ".dylan")) filename := concat(filename, ".dylan"); end; - let merged = merge-locators(as(, filename), - lid.lid-locator.locator-directory); - as(, simplify-locator(merged)) + let file = file-locator(lid.lid-locator.locator-directory, filename); + as(, simplify-locator(file)) end, lid-values(lid, $files-key) | #()); end; @@ -239,7 +238,7 @@ define function find-lids method parse-lids (dir, name, type) select (type) #"file" => - let lid-path = merge-locators(as(, name), dir); + let lid-path = file-locator(dir, name); if (~has-lid?(registry, lid-path)) let comparator = if (os/$os-name == #"win32") char-compare-ic @@ -263,7 +262,7 @@ define function find-lids // setups and it causes registry entries to be written twice. We // don't want the submodule library, we want the package library. let subdir = subdirectory-locator(dir, name); - let subdir/git = merge-locators(as(, ".git"), subdir); + let subdir/git = file-locator(subdir, ".git"); if (name ~= ".git" & ~fs/file-exists?(subdir/git)) fs/do-directory(parse-lids, subdir); end; @@ -320,10 +319,8 @@ define function ingest-spec-file // Generate "protocol", "skeletons", and "stubs" registries for CORBA projects. // The sources for these projects won't exist until generated by the build. // Assume .../foo.idl generates .../stubs/foo-stubs.hdp etc. - let base-dir = locator-directory(spec-path); - let idl-path = merge-locators(as(, - lid-value(spec, $idl-file-key, error?: #t)), - base-dir); + let idl-path = file-locator(locator-directory(spec-path), + lid-value(spec, $idl-file-key, error?: #t)); let idl-name = locator-base(idl-path); let prefix = lid-value(spec, $prefix-key); for (kind in #("protocol", "skeletons", "stubs")) @@ -332,15 +329,13 @@ define function ingest-spec-file // registry entry for "protocol" always. if (kind = "protocol" | string-equal-ic?("yes", lid-value(spec, as(, kind)) | "")) let lib-name = concat(prefix | idl-name, "-", kind); - let hdp-file = as(, concat(prefix | idl-name, "-", kind, ".hdp")); + let hdp-file = concat(prefix | idl-name, "-", kind, ".hdp"); let dir-name = iff(prefix, concat(prefix, "-", kind), kind); - let hdp-dir = subdirectory-locator(locator-directory(idl-path), dir-name); - let hdp-path = merge-locators(as(, hdp-file), hdp-dir); - let simple-hdp-path = simplify-locator(hdp-path); + let hdp-path = file-locator(locator-directory(idl-path), dir-name, hdp-file); let lid = make(, - locator: hdp-path, + locator: simplify-locator(hdp-path), data: begin let t = make(); t[$library-key] := vector(lib-name); @@ -408,8 +403,7 @@ define function parse-lid-file if (lid-header) let sub-lids = #(); local method filename-to-lid (filename) - let file = as(, filename); - let sub-path = merge-locators(file, locator-directory(path)); + let sub-path = file-locator(locator-directory(path), filename); let sub-lid = lid-for-path(registry, sub-path) | ingest-lid-file(registry, sub-path); if (sub-lid) diff --git a/sources/workspaces/workspaces-test.dylan b/sources/workspaces/workspaces-test.dylan index 4ff5839..ff11231 100644 --- a/sources/workspaces/workspaces-test.dylan +++ b/sources/workspaces/workspaces-test.dylan @@ -3,7 +3,7 @@ module: deft-test-suite define test test-new () let test-dir = test-temp-directory(); let ws-dir = subdirectory-locator(test-dir, "workspace-1"); - let ws-file = merge-locators(as(, $workspace-file-name), ws-dir); + let ws-file = file-locator(ws-dir, $workspace-file-name); assert-false(file-exists?(ws-dir)); let workspace = new("workspace-1", parent-directory: test-dir); assert-true(file-exists?(ws-file)); @@ -14,9 +14,8 @@ define test test-find-workspace-directory () // Shouldn't need this call to resolve-locator. // https://github.com/dylan-lang/testworks/issues/157 let tmp = resolve-locator(test-temp-directory()); - let ws = merge-locators(as(, $workspace-file-name), tmp); - let dp = merge-locators(as(, $dylan-package-file-name), - subdirectory-locator(tmp, "dp")); + let ws = file-locator(tmp, $workspace-file-name); + let dp = file-locator(tmp, "dp", $dylan-package-file-name); let bottom = subdirectory-locator(tmp, "dp", "abc", "xyz"); ensure-directories-exist(bottom); diff --git a/sources/workspaces/workspaces.dylan b/sources/workspaces/workspaces.dylan index 4b8f968..e8ce724 100644 --- a/sources/workspaces/workspaces.dylan +++ b/sources/workspaces/workspaces.dylan @@ -45,8 +45,7 @@ define function new => (w :: false-or()) let dir = parent-directory | fs/working-directory(); let ws-dir = subdirectory-locator(dir, name); - let ws-file = as(, $workspace-file-name); - let ws-path = merge-locators(ws-file, ws-dir); + let ws-path = file-locator(ws-dir, $workspace-file-name); let existing = find-workspace-file(dir); if (existing) workspace-error("Can't create workspace file %s because it is inside another" @@ -230,10 +229,8 @@ end function; // `directory` is expected to be the workspace root directory. define function find-active-packages (directory :: ) => (pkgs :: ) - let dpkg-file = merge-locators(as(, $dylan-package-file-name), - directory); - let pkg-file = merge-locators(as(, $pkg-file-name), - directory); + let dpkg-file = file-locator(directory, $dylan-package-file-name); + let pkg-file = file-locator(directory, $pkg-file-name); if (fs/file-exists?(dpkg-file)) vector(pm/load-dylan-package-file(dpkg-file)) elseif (fs/file-exists?(pkg-file)) @@ -242,8 +239,8 @@ define function find-active-packages let packages = make(); for (locator in fs/directory-contents(directory)) if (instance?(locator, )) - let loc = merge-locators(as(, $dylan-package-file-name), locator); - let loc2 = merge-locators(as(, $pkg-file-name), locator); + let loc = file-locator(locator, $dylan-package-file-name); + let loc2 = file-locator(locator, $pkg-file-name); if (fs/file-exists?(loc)) let pkg = pm/load-dylan-package-file(loc); add!(packages, pkg); @@ -277,12 +274,12 @@ end function; define function active-package-file (ws :: , pkg-name :: ) => (f :: ) let dir = active-package-directory(ws, pkg-name); - let loc = merge-locators(as(, $dylan-package-file-name), dir); - let loc2 = merge-locators(as(, $pkg-file-name), dir); - if (fs/file-exists?(loc2) & ~fs/file-exists?(loc)) - loc2 + let dpkg = file-locator(dir, $dylan-package-file-name); + let pkg = file-locator(dir, $pkg-file-name); + if (fs/file-exists?(pkg) & ~fs/file-exists?(dpkg)) + pkg else - loc + dpkg end end function; From 251509ce515287c42e0f906f1d4b2b277974de63 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Wed, 18 Dec 2024 13:56:09 -0500 Subject: [PATCH 02/12] cleanup: Remove unused source-file-map function The comment implied it was used by lsp-dylan but it isn't, at least not any more. --- sources/library.dylan | 1 - sources/workspaces/registry-test.dylan | 46 -------------------------- sources/workspaces/registry.dylan | 27 --------------- 3 files changed, 74 deletions(-) diff --git a/sources/library.dylan b/sources/library.dylan index 0915534..f67f260 100644 --- a/sources/library.dylan +++ b/sources/library.dylan @@ -163,7 +163,6 @@ define module workspaces find-workspace-file, load-workspace, new, - source-file-map, update, workspace-active-packages, workspace-default-library-name, diff --git a/sources/workspaces/registry-test.dylan b/sources/workspaces/registry-test.dylan index c7fceb7..9faa082 100644 --- a/sources/workspaces/registry-test.dylan +++ b/sources/workspaces/registry-test.dylan @@ -19,49 +19,3 @@ define test test-parse-lid-file--lid-header () assert-equal("v1", lid-value(child-lid, #"h1")); assert-equal("v2", lid-value(child-lid, #"h2")); end test; - -define test test-source-file-map--basics () - let text = "Library: foo\nFiles: library\n foo.dylan"; - let lid-path = write-test-file("foo.lid", contents: text); - let directory = locator-directory(lid-path); - let file-map = source-file-map(directory); - assert-equal(2, file-map.size); - - // Note that the "library" file intentionally has no ".dylan" extension, and - // the extension is expected to be added in the map keys. - for (filename in #("library.dylan", "foo.dylan")) - let full-locator = file-locator(directory, filename); - let full-path = as(, full-locator); - assert-equal(#("foo"), - element(file-map, full-path, default: #f), - format-to-string("source mapping for %=", full-path)); - end; -end test; - -// Test including another LID via the "LID" header. Also exercises the code -// that has to handle LID files that have no "Library" header. -define test test-source-file-map--included-lid () - let abc-text = "Library: abc\nFiles: library\nLID: sub.lid"; - let test-text = "Library: abc-test-suite\nFiles:test-library\nLID: sub.lid"; - let sub-text = "Files: a\n b\n c"; - - let lid-path = write-test-file("abc.lid", contents: abc-text); - write-test-file("abc-test-suite.lid", contents: test-text); - write-test-file("sub.lid", contents: sub-text); - let directory = lid-path.locator-directory; - let file-map = source-file-map(directory); - assert-equal(5, file-map.size); - - for (item in #(#(#("abc"), "library.dylan"), - #(#("abc-test-suite"), "test-library.dylan"), - #(#("abc", "abc-test-suite"), "a.dylan", "b.dylan", "c.dylan"))) - let (libraries, #rest filenames) = apply(values, item); - for (filename in filenames) - let full-locator = file-locator(directory, filename); - let full-path = as(, full-locator); - assert-equal(sort(libraries), - sort(element(file-map, full-path, default: #())), - format-to-string("source mapping for %=", full-path)); - end; - end; -end test; diff --git a/sources/workspaces/registry.dylan b/sources/workspaces/registry.dylan index 61b23e0..cd9b486 100644 --- a/sources/workspaces/registry.dylan +++ b/sources/workspaces/registry.dylan @@ -434,30 +434,3 @@ define method find-library-names find-lids(registry, registry.root-directory)), #f) end method; - - -// Build a map from source file names (absolute pathname strings) to the names -// of libraries they belong to (a sequence of strings). For now we only look at -// .dylan files (i.e., the Files: header) since this is designed for use by the -// lsp-dylan library and that's what it cares about. -define function source-file-map - (dir :: ) => (map ::
) - let registry = make(, root-directory: dir); - let file-map - // This wouldn't be necessary if we had an implementation. - // Then I'd use locators as the keys, which is cross-platform. - = make(if (os/$os-name == #"win32") else end); - for (lid in find-lids(registry, dir)) - let library = lid-value(lid, $library-key); - if (library) - for (pathname in dylan-source-files(lid)) - let libraries - = add-new!(element(file-map, pathname, default: #()), - library, - test: string-equal-ic?); - file-map[pathname] := libraries; - end for; - end if; - end for; - file-map -end function; From 537c264186b3392ff78064bf72f7c51c6b1c0d78 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Wed, 18 Dec 2024 15:50:29 -0500 Subject: [PATCH 03/12] cleanup: complete rework of workspace code The main point was to make the code easier to follow. Initial implementation I was feeling my way in the dark, this time a few things were clarified. I see the light!... * Some commands (help, list, etc.) don't need a full scan of the workspace, so I made all the `lids-by-*` slots be lazily computed. * Scanning the workspace is more clearly separated into first scanning the active packages and then, if necessary, finding and installing dependencies before scanning them for libraries. * Move LID file code to its own file, lid.dylan. --- Makefile | 1 + ext/command-line-parser | 2 +- ext/uncommon-dylan | 2 +- sources/commands/build.dylan | 27 +- sources/commands/new-library.dylan | 3 +- sources/commands/publish.dylan | 4 +- sources/commands/simple-commands.dylan | 66 ++-- sources/commands/update.dylan | 46 +++ sources/deft.lid | 2 + sources/library.dylan | 32 +- sources/main.dylan | 2 +- sources/workspaces/lid.dylan | 211 +++++++++++ sources/workspaces/registry-test.dylan | 6 +- sources/workspaces/registry.dylan | 447 +++-------------------- sources/workspaces/workspaces-test.dylan | 10 - sources/workspaces/workspaces.dylan | 406 ++++++++++---------- 16 files changed, 613 insertions(+), 654 deletions(-) create mode 100644 sources/commands/update.dylan create mode 100644 sources/workspaces/lid.dylan diff --git a/Makefile b/Makefile index 0e2fecf..cde1aa6 100644 --- a/Makefile +++ b/Makefile @@ -33,6 +33,7 @@ really-install: mkdir -p $(DYLAN)/bin cp _build/sbin/deft-app $(DYLAN)/bin/deft ln -f $(DYLAN)/bin/deft $(DYLAN)/bin/deft-app + ln -f $(DYLAN)/bin/deft $(DYLAN)/bin/dylan install: build-with-version really-install diff --git a/ext/command-line-parser b/ext/command-line-parser index b2f1847..4e73ed6 160000 --- a/ext/command-line-parser +++ b/ext/command-line-parser @@ -1 +1 @@ -Subproject commit b2f1847024b8e747fae859b3dd3d48211a633c0f +Subproject commit 4e73ed605f09e8ad605ef53d49583f5985489d4d diff --git a/ext/uncommon-dylan b/ext/uncommon-dylan index e38f976..440a3b9 160000 --- a/ext/uncommon-dylan +++ b/ext/uncommon-dylan @@ -1 +1 @@ -Subproject commit e38f97643aa9665e7e53520675621e5089419bd1 +Subproject commit 440a3b9af72dd71e77313f7ee1216ed061014e91 diff --git a/sources/commands/build.dylan b/sources/commands/build.dylan index a90d6f8..568e6a5 100644 --- a/sources/commands/build.dylan +++ b/sources/commands/build.dylan @@ -35,15 +35,14 @@ define constant $build-subcommand define method execute-subcommand (parser :: , subcmd :: ) => (status :: false-or()) - let workspace = ws/load-workspace(); + let ws = ws/load-workspace(); let library-names = get-option-value(subcmd, "libraries") | #[]; let all? = get-option-value(subcmd, "all"); if (all?) if (~empty?(library-names)) warn("Ignoring --all option. Using the specified libraries instead."); else - library-names - := ws/find-active-package-library-names(workspace); + library-names := active-package-libraries(ws); if (empty?(library-names)) error("No libraries found in workspace."); end; @@ -51,7 +50,7 @@ define method execute-subcommand end; if (empty?(library-names)) library-names - := list(ws/workspace-default-library-name(workspace) + := list(ws/workspace-default-library-name(ws) | error("No libraries found in workspace and no" " default libraries configured.")); end; @@ -66,20 +65,21 @@ define method execute-subcommand name), #f); debug("Running command %=", command); - let env = make-compilation-environment(workspace); + let env = make-compilation-environment(ws); let exit-status = os/run-application(command, environment: env, // adds to the existing environment under-shell?: #f, - working-directory: ws/workspace-directory(workspace)); + working-directory: ws/workspace-directory(ws)); if (exit-status ~== 0) error("Build of %= failed with exit status %=.", name, exit-status); end; end for; end method; -define function make-compilation-environment (ws :: ws/) => (env ::
) - let val = as(, ws/workspace-registry-directory(ws)); +define function make-compilation-environment + (ws :: ws/) => (env ::
) + let val = as(, ws/registry-directory(ws)); let var = "OPEN_DYLAN_USER_REGISTRIES"; let odur = os/environment-variable(var); if (odur) @@ -88,3 +88,14 @@ define function make-compilation-environment (ws :: ws/) => (env :: < end; tabling(, var => val) end function; + +define function active-package-libraries + (ws :: ws/) => (libraries :: ) + collecting () + for (lids in ws/lids-by-active-package(ws)) + for (lid in lids) + collect(ws/library-name(lid)); + end; + end; + end +end function; diff --git a/sources/commands/new-library.dylan b/sources/commands/new-library.dylan index bd93762..4baa949 100644 --- a/sources/commands/new-library.dylan +++ b/sources/commands/new-library.dylan @@ -433,7 +433,8 @@ define function make-dylan-library note("Created library %s.", name) end; end; - ws/update(directory: dir); + let ws = ws/load-workspace(directory: dir); + update-workspace(ws); end function; // Parse dependency specs like lib, lib@latest, or lib@1.2. Deps are always diff --git a/sources/commands/publish.dylan b/sources/commands/publish.dylan index 5861eec..b13d476 100644 --- a/sources/commands/publish.dylan +++ b/sources/commands/publish.dylan @@ -17,8 +17,8 @@ define constant $publish-subcommand define method execute-subcommand (parser :: , subcmd :: ) => (status :: false-or()) - let workspace = ws/load-workspace(); - let release = ws/workspace-release(workspace); + let release = ws/current-dylan-package(fs/working-directory()) + | error("No Dylan package file found. Not inside a workspace?"); let cat-dir = as(, get-option-value($publish-subcommand, "catalog-directory")); let cat = pm/catalog(directory: cat-dir); diff --git a/sources/commands/simple-commands.dylan b/sources/commands/simple-commands.dylan index f343257..c5da827 100644 --- a/sources/commands/simple-commands.dylan +++ b/sources/commands/simple-commands.dylan @@ -2,6 +2,10 @@ Module: deft Synopsis: Various command implementations not big enough to warrant their own file +// TODO: put each command in its own file, more or less. Having a bunch of random small +// commands in this file just makes them harder to find. + + /// deft install define class () @@ -38,6 +42,9 @@ end method; /// deft list +// TODO: this should show locally installed packages by default, but have a --global +// flag. + define class () keyword name = "list"; keyword help = "List installed Dylan packages."; @@ -137,35 +144,49 @@ define method execute-subcommand => (status :: false-or()) let name = get-option-value(subcmd, "name"); let dir = get-option-value(subcmd, "directory"); - ws/new(name, parent-directory: dir & as(, dir)); + new(name, parent-directory: dir & as(, dir)); 0 end method; +// Create a new workspace named `name` under `parent-directory`. If `parent-directory` is +// not supplied use the standard location. +// +// TODO: validate `name` +define function new + (name :: , #key parent-directory :: false-or()) + => (ws :: false-or(ws/)) + let dir = parent-directory | fs/working-directory(); + let ws-dir = subdirectory-locator(dir, name); + let ws-path = file-locator(ws-dir, ws/$workspace-file-name); + let existing = ws/find-workspace-file(dir); + if (existing) + ws/workspace-error("Can't create workspace file %s because it is inside another" + " workspace, %s.", ws-path, existing); + end; + if (fs/file-exists?(ws-path)) + note("Workspace already exists: %s", ws-path); + else + fs/ensure-directories-exist(ws-path); + fs/with-open-file (stream = ws-path, + direction: #"output", if-does-not-exist: #"create", + if-exists: #"error") + format(stream, """ + # Dylan workspace %= -/// deft update - -define class () - keyword name = "update"; - keyword help = "Update the workspace based on the active packages."; -end class; - -define constant $update-subcommand - = make(, - options: list(make(, - names: #("global"), - help: "Install packages globally instead of in the" - " workspace. [%default%]"))); + {} -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - let global? = get-option-value(subcmd, "global"); - ws/update(global?: global?); -end method; + """, name); + end; + note("Workspace created: %s", ws-path); + end; + ws/load-workspace(directory: ws-dir) +end function; /// deft status +// TODO: show active package dependencies and whether or not they're installed. + define class () keyword name = "status"; keyword help = "Display information about the current workspace."; @@ -177,14 +198,11 @@ define constant $status-subcommand name: "directory", help: "Only show the workspace directory."))); +// TODO: show settings like default library name. define method execute-subcommand (parser :: , subcmd :: ) => (status :: false-or()) let workspace = ws/load-workspace(); - if (~workspace) - note("Not currently in a workspace."); - abort-command(1); - end; note("Workspace: %s", ws/workspace-directory(workspace)); if (get-option-value(subcmd, "directory")) abort-command(0); diff --git a/sources/commands/update.dylan b/sources/commands/update.dylan new file mode 100644 index 0000000..b7fd942 --- /dev/null +++ b/sources/commands/update.dylan @@ -0,0 +1,46 @@ +Module: deft +Synopsis: deft update subcommand + + +define class () + keyword name = "update"; + keyword help = "Install active package dependencies and write registry files." +end class; + +define constant $update-subcommand + = make(, + options: list(make(, + names: #("global"), + help: "Install packages globally instead of in the" + " workspace. [%default%]"))); + +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + update-workspace(ws/load-workspace(), + global?: get-option-value(subcmd, "global")); +end method; + +define function update-workspace + (ws :: ws/, #key global? :: ) => () + let cat = pm/catalog(); + dynamic-bind (*package-manager-directory* + = iff(global?, + *package-manager-directory*, + subdirectory-locator(ws/workspace-directory(ws), + pm/$package-directory-name))) + let (releases, actives) = ws/ensure-deps-installed(ws); + let (total :: , written :: , no-platform :: ) + = ws/update-registry(ws, releases, actives); + if (~empty?(no-platform) & *verbose?*) + warn("These libraries had no LID file for platform %s:\n %s", + os/$platform-name, join(sort!(no-platform), ", ")); + end; + let reg-dir = ws/registry-directory(ws); + if (written == 0) + note("Registry %s is up-to-date (%d files).", reg-dir, total); + else + note("Updated %d of %d registry files in %s.", written, total, reg-dir); + end; + end; +end function; diff --git a/sources/deft.lid b/sources/deft.lid index b7fc7c2..1c1f8bc 100644 --- a/sources/deft.lid +++ b/sources/deft.lid @@ -7,6 +7,7 @@ Files: library.dylan pacman/catalog.dylan pacman/deps.dylan pacman/install.dylan + workspaces/lid.dylan workspaces/registry.dylan workspaces/workspaces.dylan commands/utils.dylan @@ -14,4 +15,5 @@ Files: library.dylan commands/new-library.dylan commands/publish.dylan commands/build.dylan + commands/update.dylan commands/command-line.dylan diff --git a/sources/library.dylan b/sources/library.dylan index f67f260..f971fcf 100644 --- a/sources/library.dylan +++ b/sources/library.dylan @@ -2,7 +2,7 @@ Module: dylan-user define library deft use collections, - import: { table-extensions }; + import: { collectors, table-extensions }; use command-line-parser; use dylan, import: { dylan-extensions, threads }; @@ -88,6 +88,7 @@ define module pacman release-dependencies, release-dev-dependencies, release-license, + release-package, release-to-string, release-url, release-version, @@ -152,26 +153,30 @@ define module workspaces $dylan-package-file-name, $workspace-file-name, , + workspace-error, , active-package-directory, active-package-file, active-package?, - find-active-package-library-names, + current-dylan-package, + ensure-deps-installed, find-dylan-package-file, - find-library-names, find-workspace-directory, find-workspace-file, + library-name, + lids-by-active-package, + lids-by-library, + lids-by-pathname, load-workspace, - new, - update, + registry-directory, + update-registry, workspace-active-packages, workspace-default-library-name, - workspace-directory, - workspace-registry-directory, - workspace-release; + workspace-directory; end module; define module %workspaces + use collectors; use dylan-extensions, import: { address-of }; use file-source-records, prefix: "sr/"; @@ -204,11 +209,11 @@ define module %workspaces lid-data, lid-value, lid-values, - parse-lid-file, - ; + parse-lid-file; end module; define module deft + use collectors; use command-line-parser; use file-system, prefix: "fs/"; use format; @@ -216,12 +221,17 @@ define module deft 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 regular-expressions; use shared; use standard-io; use streams; use strings; + use threads, + import: { dynamic-bind }; use uncommon-dylan, exclude: { format-out, format-to-string }; use uncommon-utils, diff --git a/sources/main.dylan b/sources/main.dylan index a093f5e..7f07392 100644 --- a/sources/main.dylan +++ b/sources/main.dylan @@ -8,7 +8,7 @@ define function main () => (status :: false-or()) parse-command-line(parser, application-arguments()); *debug?* := get-option-value(parser, "debug"); *verbose?* := get-option-value(parser, "verbose"); - execute-command(parser); + execute-command(parser) exception (err :: ) let status = exit-status(err); if (status ~= 0) diff --git a/sources/workspaces/lid.dylan b/sources/workspaces/lid.dylan new file mode 100644 index 0000000..019bef1 --- /dev/null +++ b/sources/workspaces/lid.dylan @@ -0,0 +1,211 @@ +Module: %workspaces + +// Keys used to lookup values in a parsed LID file. +define constant $platforms-key = #"platforms"; +define constant $files-key = #"files"; +define constant $library-key = #"library"; +define constant $lid-key = #"lid"; +define constant $origin-key = #"origin"; +define constant $idl-file-key = #"idl-file"; +define constant $prefix-key = #"prefix"; + +define class () + constant slot lid-locator :: , + required-init-keyword: locator:; + + // A map from to sequences of , one for each line + // associated with the key. Ex: #"files" => #["foo.dylan", "bar.dylan"] + constant slot lid-data ::
, + required-init-keyword: data:; + + // Sequence of other s in which this is included via the "LID:" + // keyword. + constant slot lid-included-in :: = make(); +end class; + +define method print-object + (lid :: , stream :: ) => () + // TODO: use printing-object:print:io + format(stream, "#", lid-value(lid, $library-key), address-of(lid)); +end method; + +define function lid-values + (lid :: , key :: ) => (_ :: false-or()) + element(lid.lid-data, key, default: #f) +end function; + +// The potential types that may be returned from lid-value. +define constant = type-union(, , singleton(#f)); + +define function lid-value + (lid :: , key :: , #key error? :: ) => (v :: ) + let items = element(lid.lid-data, key, default: #f); + if (items & items.size = 1) + items[0] + elseif (error?) + workspace-error("A single value was expected for key %=. Got %=. LID: %s", + key, items, lid.lid-locator); + end +end function; + +define function library-name + (lid :: ) => (name :: false-or()) + lid-value(lid, $library-key, error?: #f) +end function; + +// Return the transitive (via files included with the "LID" header) contents of +// the "Files" LID header. +define function dylan-source-files + (lid :: ) => (files :: ) + let files = #(); + local method source-files (lid) + map(method (filename) + if (~ends-with?(lowercase(filename), ".dylan")) + filename := concat(filename, ".dylan"); + end; + let file = file-locator(lid.lid-locator.locator-directory, filename); + as(, simplify-locator(file)) + end, + lid-values(lid, $files-key) | #()); + end; + local method do-lid (lid) + files := concat(files, source-files(lid)); + for (child in lid-values(lid, $lid-key) | #()) + do-lid(child) + end; + end; + do-lid(lid); + files +end function; + +define function add-lid + (ws :: , active-package :: false-or(pm/), 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); + end; + ws.%lids-by-library[library-name] := pair(lid, lids); + end; + ws.%lids-by-pathname[as(, 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; + +// Read a from `lid-path` and store it in `registry`. Returns the , +// or #f if nothing ingested. +define function ingest-lid-file + (ws :: , active-package :: false-or(pm/), lid-path :: ) + => (lid :: false-or()) + let lid = parse-lid-file(ws, active-package, lid-path); + if (empty?(dylan-source-files(lid))) + warn("LID file %s has no (transitive) 'Files' property.", lid-path); + end; + if (skip-lid?(ws, lid)) + warn("Skipping %s, preferring previous .lid file.", lid-path); + #f + else + add-lid(ws, active-package, lid); + lid + end +end function; + +// Returns true if `lid` has "hdp" extension and an existing LID in the same +// directory has "lid" extension, since the hdp files are usually automatically +// generated from the LID. +define function skip-lid? + (ws :: , lid :: ) => (skip? :: ) + if (string-equal-ic?("hdp", lid.lid-locator.locator-extension)) + let library = lid-value(lid, $library-key, error?: #t); + let directory = lid.lid-locator.locator-directory; + let existing = choose(method (x) + x.lid-locator.locator-directory = directory + end, + element(ws.%lids-by-library, library, default: #[])); + // Why only size = 1? Shouldn't I be looking for exactly lid.locator-name + ".lid" + existing.size = 1 + & string-equal-ic?("lid", existing[0].lid-locator.locator-extension) + end +end function; + +// Read a CORBA spec file and store a into `ws` for each of the +// generated libraries. +define function ingest-spec-file + (ws :: , active-package :: false-or(pm/), spec-path :: ) + => (lids :: ) + let spec :: = parse-lid-file(ws, active-package, spec-path); + let origin = lid-value(spec, $origin-key, error?: #t); + let lids = #(); + if (string-equal-ic?(origin, "omg-idl")) + // Generate "protocol", "skeletons", and "stubs" registries for CORBA projects. + // The sources for these projects won't exist until generated by the build. + // Assume .../foo.idl generates .../stubs/foo-stubs.hdp etc. + let idl-path = file-locator(locator-directory(spec-path), + lid-value(spec, $idl-file-key, error?: #t)); + let idl-name = locator-base(idl-path); + let prefix = lid-value(spec, $prefix-key); + for (kind in #("protocol", "skeletons", "stubs")) + // Unsure as to why the remote-nub-protocol library doesn't need + // "protocol: yes" in its .lid file, but what the heck, just generate a + // registry entry for "protocol" always. + if (kind = "protocol" | string-equal-ic?("yes", lid-value(spec, as(, kind)) | "")) + let lib-name = concat(prefix | idl-name, "-", kind); + let hdp-file = concat(prefix | idl-name, "-", kind, ".hdp"); + let dir-name = iff(prefix, + concat(prefix, "-", kind), + kind); + let hdp-path = file-locator(locator-directory(idl-path), dir-name, hdp-file); + let lid = make(, + locator: simplify-locator(hdp-path), + data: begin + let t = make(
); + t[$library-key] := vector(lib-name); + t + end); + add-lid(ws, active-package, lid); + lids := pair(lid, lids); + end; + end for; + end if; + lids +end function; + +// Parse the contents of `path` into a new `` and return it. Every LID +// keyword is turned into a symbol and used as the table key, and the data +// associated with that keyword is stored as a sequence of strings, even if the +// keyword is known to allow only a single value. There is one exception: the +// "LID:" keyword is recursively parsed into a sequence of `` objects. For +// example: +// +// #"library" => #("http") +// #"files" => #("foo.dylan", "bar.dylan") +// #"LID" => #({}, {}) +define function parse-lid-file + (ws :: , active-package :: false-or(pm/), path :: ) + => (lid :: ) + let headers = sr/read-file-header(path); + let library = element(headers, $library-key, default: #f); + let locator = simplify-locator(path); + let lid = make(, locator: locator, data: headers); + let lid-header = element(headers, $lid-key, default: #f); + if (lid-header) + let sub-lids = #(); + local method filename-to-lid (filename) + let sub-path = file-locator(locator-directory(path), filename); + let sub-lid = element(ws.%lids-by-pathname, as(, sub-path), default: #f) + | ingest-lid-file(ws, active-package, sub-path); + if (sub-lid) + sub-lids := add-new!(sub-lids, sub-lid); + add-new!(sub-lid.lid-included-in, lid); + end; + sub-lid + end; + // ingest-lid-file can return #f, hence remove() + headers[$lid-key] := remove(map(filename-to-lid, lid-header), #f); + end; + lid +end function; diff --git a/sources/workspaces/registry-test.dylan b/sources/workspaces/registry-test.dylan index 9faa082..72371c6 100644 --- a/sources/workspaces/registry-test.dylan +++ b/sources/workspaces/registry-test.dylan @@ -1,14 +1,14 @@ Module: deft-test-suite // The low-level LID parsing is done by the file-source-records library so this -// test is mainly concerned with whether parsing the LID: header works. +// test is mainly concerned with whether parsing the "LID:" header works. define test test-parse-lid-file--lid-header () let parent-file = write-test-file("parent.lid", contents: "library: foo\nlid: child.lid\n"); let child-file = write-test-file("child.lid", contents: "h1: v1\nh2: v2\n"); - let registry = make(, root-directory: locator-directory(parent-file)); - let parent-lid = parse-lid-file(registry, parent-file); + let ws = make(, directory: locator-directory(parent-file)); + let parent-lid = parse-lid-file(ws, #f, parent-file); assert-equal(2, parent-lid.lid-data.size); let sub-lids = lid-values(parent-lid, $lid-key) | #[]; diff --git a/sources/workspaces/registry.dylan b/sources/workspaces/registry.dylan index cd9b486..9e5eabe 100644 --- a/sources/workspaces/registry.dylan +++ b/sources/workspaces/registry.dylan @@ -2,356 +2,21 @@ Module: %workspaces Synopsis: Scan for LID files and generate a registry -define class () -end; - -//// REGISTRY - -// Keys used to lookup values in a parsed LID file. -define constant $platforms-key = #"platforms"; -define constant $files-key = #"files"; -define constant $library-key = #"library"; -define constant $lid-key = #"lid"; -define constant $origin-key = #"origin"; -define constant $idl-file-key = #"idl-file"; -define constant $prefix-key = #"prefix"; - -// A knows how to find and parse LID files and write registry files -// for them. -define class () - - // The directory containing the "registry" directory, where files will be written. - constant slot root-directory :: , - required-init-keyword: root-directory:; - - // A map from library names to sequences of s that define the library. - // (A library with platform-specific definitions may have multiple lids.) - constant slot lids-by-library :: = make(); - - // A map from full absolute pathname to the associated . - constant slot lids-by-pathname :: = make(); - - // This is a hack to prevent logging warning messages multiple times. I - // could probably have avoided this if I'd written the code in a more - // functional style rather than mutating the registry everywhere, but at this - // point it would require a big rewrite: find all lids for all active - // packages and dependencies without generating any warnings, then iterate - // over the library=>lid map deciding which files to write and logging - // warnings once for a given library. - constant slot updated-libraries :: = make(); - - // Libraries that have no LID file for the requested platform. - constant slot libraries-with-no-lid = make(); - slot num-files-written = 0; -end class; - -define function has-lid? - (registry :: , path :: ) => (_ :: ) - element(registry.lids-by-pathname, as(, path), default: #f) & #t -end function; - -// Find a in `registry` that was parsed from `path`. -define function lid-for-path - (registry :: , path :: ) - => (lid :: false-or()) - element(registry.lids-by-pathname, as(, path), default: #f) -end function; - -define function add-lid - (registry :: , lid :: ) => () - let library-name = lid-value(lid, $library-key); - if (library-name) - let v = element(registry.lids-by-library, library-name, default: #f); - v := v | make(); - add-new!(v, lid); - registry.lids-by-library[library-name] := v; - end; - registry.lids-by-pathname[as(, lid.lid-locator)] := lid; -end function; - // Return a registry file locator for the library named by `lid`. define function registry-file-locator - (registry :: , lid :: ) => (_ :: ) + (ws :: , lid :: ) => (_ :: ) let platform = as(, os/$platform-name); - let directory = subdirectory-locator(registry.root-directory, "registry", platform); + let directory = subdirectory-locator(ws.workspace-directory, "registry", platform); // The registry file must be written in lowercase so that on unix systems the // compiler can find it. let lib = lowercase(lid-value(lid, $library-key, error?: #t)); file-locator(directory, lib) end function; - -//// LID - -// A holds key/value pairs from a LID file. -define class () - constant slot lid-locator :: , - required-init-keyword: locator:; - - // A map from to sequences of , one for each line - // associated with the key. Ex: #"files" => #["foo.dylan", "bar.dylan"] - constant slot lid-data ::
, - required-init-keyword: data:; - - // Sequence of other s in which this is included via the "LID:" - // keyword. - constant slot lid-included-in :: = make(); -end class; - -define method print-object - (lid :: , stream :: ) => () - format(stream, "#", lid-value(lid, $library-key), address-of(lid)); -end method; - -define function lid-values - (lid :: , key :: ) => (_ :: false-or()) - element(lid.lid-data, key, default: #f) -end function; - -// The potential types that may be returned from lid-value. -define constant = type-union(, , singleton(#f)); - -define function lid-value - (lid :: , key :: , #key error? :: ) => (v :: ) - let items = element(lid.lid-data, key, default: #f); - if (items & items.size = 1) - items[0] - elseif (error?) - error(make(, - format-string: "A single value was expected for key %=. Got %=. LID: %s", - format-arguments: list(key, items, lid.lid-locator))) - end -end function; - -define function has-key? - (lid :: , key :: ) => (_ :: ) - element(lid.lid-data, key, default: #f) & #t -end function; - -define function has-key-value? - (lid :: , key :: , value :: ) => (_ :: ) - member?(value, lid-values(lid, key) | #[], test: string-equal-ic?) -end function; - -// Return the transitive (via files included with the "LID" header) contents of -// the "Files" LID header. -define function dylan-source-files (lid :: ) => (files :: ) - let files = #(); - local method source-files (lid) - map(method (filename) - if (~ends-with?(lowercase(filename), ".dylan")) - filename := concat(filename, ".dylan"); - end; - let file = file-locator(lid.lid-locator.locator-directory, filename); - as(, simplify-locator(file)) - end, - lid-values(lid, $files-key) | #()); - end; - local method do-lid (lid) - files := concat(files, source-files(lid)); - for (child in lid-values(lid, $lid-key) | #()) - do-lid(child) - end; - end; - do-lid(lid); - files -end function; - -// Find all the LID files in `pkg-dir` that are marked as being for the current -// platform and create registry files for the corresponding libraries. First do -// a pass over the entire directory reading lid files, then write registry -// files for the ones that aren't included in other LID files. (This avoids -// writing the same registry file twice for the same library without resorting -// to putting "Platforms: none" in LID files that are included in other LID -// files.) -define function update-for-directory - (registry :: , dir :: ) => () - for (lid :: in update-lids(registry, dir)) - write-registry-file(registry, lid); - end; -end function; - -// Find all the LID files in `dir` that are marked as being for the current -// platform and add them to `registry`. First do a pass over the entire -// directory reading lid files, then write registry files for the ones that -// aren't included in other LID files. (This avoids writing the same registry -// file twice for the same library without resorting to putting "Platforms: -// none" in LID files that are included in other LID files.) -define function update-lids - (registry :: , dir :: , - #key platform :: = os/$platform-name) - => (lids :: ) - // First find all the LIDs, then trim them down based on platform. - let lids = find-lids(registry, dir); - let keep = #(); - // For each library, write a LID if there's one explicitly for this platform, - // or there's one with no platforms specified at all (as long as it isn't - // included in another LID). - let current-platform = as(, os/$platform-name); - let updated-libs = registry.updated-libraries; - for (lids keyed-by library-name in registry.lids-by-library) - let candidates = #(); - block (done) - for (lid :: in lids) - if (has-key-value?(lid, $platforms-key, current-platform)) - candidates := list(lid); - done(); - elseif (~has-key?(lid, $platforms-key) & empty?(lid.lid-included-in)) - candidates := pair(lid, candidates); - end; - end; - end block; - select (candidates.size) - 0 => - if (~element(updated-libs, library-name, default: #f)) - // We'll display these at the end, as a group. - add-new!(registry.libraries-with-no-lid, library-name, test: \=); - end; - 1 => - write-registry-file(registry, candidates[0]); - otherwise => - if (~element(updated-libs, library-name, default: #f)) - // This is a real error and should always be logged regardless of - // the *verbose?* value. - warn("Library %= has multiple .lid files for platform %=.\n" - " %s\nRegistry will point to the first one, arbitrarily.", - library-name, current-platform, - join(candidates, "\n ", key: method (lid) - as(, lid.lid-locator) - end)); - end; - write-registry-file(registry, candidates[0]); - end select; - updated-libs[library-name] := #t; - end for; - keep -end function; - -// Descend pkg-dir parsing .lid, .hdp, or .spec files. Updates `registry`s -// internal maps. .hdp files are (I believe) obsolecent so the .lid file is -// preferred. For .spec files the corresponding .hdp file may not exist yet so -// the table returned for it just has a #"library" key, which is enough. -define function find-lids - (registry :: , pkg-dir :: ) => (lids :: ) - let lids = #(); - local - method parse-lids (dir, name, type) - select (type) - #"file" => - let lid-path = file-locator(dir, name); - if (~has-lid?(registry, lid-path)) - let comparator = if (os/$os-name == #"win32") - char-compare-ic - else - char-compare - end; - select (name by rcurry(ends-with?, test: comparator)) - ".lid", ".hdp" => - let lid = ingest-lid-file(registry, lid-path); - if (lid) - lids := pair(lid, lids); - end; - ".spec" => - lids := concat(lids, ingest-spec-file(registry, lid-path)); - otherwise - => #f; - end; - end; - #"directory" => - // Skip git submodules; their use is a vestige of pre-package manager - // setups and it causes registry entries to be written twice. We - // don't want the submodule library, we want the package library. - let subdir = subdirectory-locator(dir, name); - let subdir/git = file-locator(subdir, ".git"); - if (name ~= ".git" & ~fs/file-exists?(subdir/git)) - fs/do-directory(parse-lids, subdir); - end; - #"link" => #f; - end select; - end method; - fs/do-directory(parse-lids, pkg-dir); - lids -end function; - -// Read a from `lid-path` and store it in `registry`. Returns the , -// or #f if nothing ingested. -define function ingest-lid-file - (registry :: , lid-path :: ) - => (lid :: false-or()) - let lid = parse-lid-file(registry, lid-path); - if (empty?(dylan-source-files(lid))) - warn("LID file %s has no (transitive) 'Files' property.", lid-path); - end; - if (skip-lid?(registry, lid)) - note("Skipping %s, preferring previous .lid file.", lid-path); - #f - else - add-lid(registry, lid); - lid - end -end function; - -// Returns true if `lid` has "hdp" extension and an existing LID in the same -// directory has "lid" extension, since the hdp files are usually automatically -// generated from the LID. -define function skip-lid? - (registry :: , lid :: ) => (skip? :: ) - if (string-equal-ic?("hdp", lid.lid-locator.locator-extension)) - let library-name = lid-value(lid, $library-key, error?: #t); - let directory = lid.lid-locator.locator-directory; - let existing = choose(method (x) - x.lid-locator.locator-directory = directory - end, - element(registry.lids-by-library, library-name, default: #[])); - existing.size = 1 - & string-equal-ic?("lid", existing[0].lid-locator.locator-extension) - end -end function; - -// Read a CORBA spec file and store a into `registry` for each of the -// generated libraries. -define function ingest-spec-file - (registry :: , spec-path :: ) => (lids :: ) - let spec :: = parse-lid-file(registry, spec-path); - let origin = lid-value(spec, $origin-key, error?: #t); - let lids = #(); - if (string-equal-ic?(origin, "omg-idl")) - // Generate "protocol", "skeletons", and "stubs" registries for CORBA projects. - // The sources for these projects won't exist until generated by the build. - // Assume .../foo.idl generates .../stubs/foo-stubs.hdp etc. - let idl-path = file-locator(locator-directory(spec-path), - lid-value(spec, $idl-file-key, error?: #t)); - let idl-name = locator-base(idl-path); - let prefix = lid-value(spec, $prefix-key); - for (kind in #("protocol", "skeletons", "stubs")) - // Unsure as to why the remote-nub-protocol library doesn't need - // "protocol: yes" in its .lid file, but what the heck, just generate a - // registry entry for "protocol" always. - if (kind = "protocol" | string-equal-ic?("yes", lid-value(spec, as(, kind)) | "")) - let lib-name = concat(prefix | idl-name, "-", kind); - let hdp-file = concat(prefix | idl-name, "-", kind, ".hdp"); - let dir-name = iff(prefix, - concat(prefix, "-", kind), - kind); - let hdp-path = file-locator(locator-directory(idl-path), dir-name, hdp-file); - let lid = make(, - locator: simplify-locator(hdp-path), - data: begin - let t = make(
); - t[$library-key] := vector(lib-name); - t - end); - add-lid(registry, lid); - lids := pair(lid, lids); - end; - end for; - end if; - lids -end function; - // Write a registry file for `lid` if it doesn't exist or the content changed. -define function write-registry-file (registry :: , lid :: ) - let registry-file = registry-file-locator(registry, lid); +define function write-registry-file + (ws :: , lid :: ) => (written? :: ) + let registry-file = registry-file-locator(ws, lid); let lid-file = simplify-locator(lid.lid-locator); // Write the absolute pathname of the LID file rather than // abstract://dylan/ because the latter doesn't work reliably @@ -359,16 +24,19 @@ define function write-registry-file (registry :: , lid :: ) // C:\..\pkg\... when compiling in c:\users\cgay\dylan\workspaces\dt let new-content = format-to-string("%s\n", lid-file); let old-content = file-content(registry-file); - if (new-content ~= old-content) + if (new-content = old-content) + trace("Not writing %s (still points to %s)", registry-file, lid-file); + #f + else fs/ensure-directories-exist(registry-file); fs/with-open-file(stream = registry-file, direction: #"output", if-exists?: #"replace") write(stream, new-content); - registry.num-files-written := registry.num-files-written + 1; end; - verbose("Wrote %s (%s)", registry-file, lid-file); - end; + verbose("Wrote %s (%s)", registry-file, lid-file); + #t + end end function; // Read the full contents of a file and return it as a string. If the file @@ -384,53 +52,46 @@ define function file-content (path :: ) => (text :: false-or()) end end function; -// Parse the contents of `path` into a new `` and return it. Every LID -// keyword is turned into a symbol and used as the table key, and the data -// associated with that keyword is stored as a sequence of strings, even if the -// keyword is known to allow only a single value. There is one exception: the -// "LID:" keyword is recursively parsed into a sequence of `` objects. For -// example: -// -// #"library" => #("http") -// #"files" => #("foo.dylan", "bar.dylan") -// #"LID" => #({}, {}) -define function parse-lid-file - (registry :: , path :: ) - => (lid :: ) - let headers = sr/read-file-header(path); - let lid = make(, locator: path, data: headers); - let lid-header = element(headers, $lid-key, default: #f); - if (lid-header) - let sub-lids = #(); - local method filename-to-lid (filename) - let sub-path = file-locator(locator-directory(path), filename); - let sub-lid = lid-for-path(registry, sub-path) - | ingest-lid-file(registry, sub-path); - if (sub-lid) - sub-lids := add-new!(sub-lids, sub-lid); - add-new!(sub-lid.lid-included-in, lid); - end; - sub-lid - end; - // ingest-lid-file can return #f, hence remove() - headers[$lid-key] := remove(map(filename-to-lid, lid-header), #f); - end; - lid +// Create/update a single registry directory having an entry for each library +// in each active package and all transitive dependencies. This traverses +// package directories to find .lid files. Note that it assumes that .lid files +// that have no "Platforms:" section are generic, and writes a registry file +// for them (unless they're included in another LID file via the LID: keyword, +// in which case it is assumed they're for inclusion only). +define function update-registry + (ws :: , releases :: , actives :: ) + => (total :: , written :: , no-platform-libs :: ) + let current-platform = as(, os/$platform-name); + let total = 0; + let written = 0; + let no-platform = make(); + for (lids keyed-by library in ws.lids-by-library) + let candidates + = choose(method (lid) + let platform = lid-value(lid, $platforms-key); + platform = current-platform + | (~platform & empty?(lid.lid-included-in)) + end, + lids); + select (candidates.size) + 0 => + // We'll display these at the end, as a group. + add-new!(no-platform, library, test: \=); + 1 => + inc!(total); + write-registry-file(ws, candidates[0]) + & inc!(written); + otherwise => + warn("Library %= has multiple .lid files for platform %=.\n" + " %s\nRegistry will point to the first one, arbitrarily.", + library, current-platform, + join(candidates, "\n ", key: method (lid) + as(, lid.lid-locator) + end)); + inc!(total); + write-registry-file(ws, candidates[0]) + & inc!(written); + end select; + end for; + values(total, written, no-platform) end function; - - -// Find the names of all libraries defined in `dir`, a directory or registry. -define generic find-library-names (dir) => (names :: ); - -define method find-library-names - (dir :: ) => (names :: ) - find-library-names(make(, root-directory: dir)) -end method; - -define method find-library-names - (registry :: ) => (names :: ) - // It's possible for a LID included via the LID: keyword to not have a library. - remove(map(rcurry(lid-value, $library-key), - find-lids(registry, registry.root-directory)), - #f) -end method; diff --git a/sources/workspaces/workspaces-test.dylan b/sources/workspaces/workspaces-test.dylan index ff11231..726af67 100644 --- a/sources/workspaces/workspaces-test.dylan +++ b/sources/workspaces/workspaces-test.dylan @@ -1,15 +1,5 @@ module: deft-test-suite -define test test-new () - let test-dir = test-temp-directory(); - let ws-dir = subdirectory-locator(test-dir, "workspace-1"); - let ws-file = file-locator(ws-dir, $workspace-file-name); - assert-false(file-exists?(ws-dir)); - let workspace = new("workspace-1", parent-directory: test-dir); - assert-true(file-exists?(ws-file)); - assert-equal(workspace-directory(workspace), simplify-locator(ws-dir)); -end test; - define test test-find-workspace-directory () // Shouldn't need this call to resolve-locator. // https://github.com/dylan-lang/testworks/issues/157 diff --git a/sources/workspaces/workspaces.dylan b/sources/workspaces/workspaces.dylan index e8ce724..2d57049 100644 --- a/sources/workspaces/workspaces.dylan +++ b/sources/workspaces/workspaces.dylan @@ -1,17 +1,8 @@ module: %workspaces synopsis: Manage developer workspaces -// A workspace is just a directory with this layout: -// _build/... -- auto-generated by `dylan-compiler -build ...` -// lib1/dylan-package.json -// lib1/... -// lib2/dylan-package.json -// lib2/... -// registry/... -- auto-generated by `deft update` -// workspace.json -- workspace file with at least "{}" -// -// Generally the top-level workspace directory itself is not under version -// control. +// See the doc at https://package.opendylan.org/deft/index.html#workspaces for an +// explanation of single- and multi-package workspace layouts. // TODO: // * Display the number of registry files updated and the number unchanged. @@ -36,96 +27,74 @@ define constant $dylan-package-file-name = "dylan-package.json"; define constant $pkg-file-name = "pkg.json"; define constant $default-library-key = "default-library"; -// Create a new workspace named `name` under `parent-directory`. If `parent-directory` is -// not supplied use the standard location. -// -// TODO: validate `name` -define function new - (name :: , #key parent-directory :: false-or()) - => (w :: false-or()) - let dir = parent-directory | fs/working-directory(); - let ws-dir = subdirectory-locator(dir, name); - let ws-path = file-locator(ws-dir, $workspace-file-name); - let existing = find-workspace-file(dir); - if (existing) - workspace-error("Can't create workspace file %s because it is inside another" - " workspace, %s.", ws-path, existing); - end; - if (fs/file-exists?(ws-path)) - note("Workspace already exists: %s", ws-path); - else - fs/ensure-directories-exist(ws-path); - fs/with-open-file (stream = ws-path, - direction: #"output", if-does-not-exist: #"create", - if-exists: #"error") - format(stream, "# Dylan workspace %=\n\n{}\n", name); - end; - note("Workspace created: %s", ws-path); - end; - load-workspace(directory: ws-dir) -end function; - -// Update the workspace based on the workspace.json file or signal an error. -define function update - (#key directory :: = fs/working-directory(), - global? :: ) - => () - let ws = load-workspace(directory: directory); - let cat = pm/catalog(); - dynamic-bind (*package-manager-directory* - = if (global?) - *package-manager-directory* - else - subdirectory-locator(workspace-directory(ws), - pm/$package-directory-name) - 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); - end; - end; -end function; - // See the section "Workspaces" in the documentation. define class () constant slot workspace-directory :: , required-init-keyword: directory:; - constant slot workspace-registry :: , - required-init-keyword: registry:; constant slot workspace-active-packages :: = #[], // s init-keyword: active-packages:; - constant slot workspace-default-library-name :: false-or() = #f, - init-keyword: default-library-name:; constant slot multi-package-workspace? :: = #f, init-keyword: multi-package?:; - // The that was loaded from dylan-package.json, if any. - constant slot workspace-release :: false-or(pm/) = #f, - init-keyword: release:; + + // Default library to build, for the LSP server to open, etc. + slot workspace-default-library-name :: false-or() = #f; + + // These three %lids-by-* slots are computed lazily rather than in load-workspace + // because some deft commands don't need them. + + // A map from library names to sequences of s that define the library. (A library + // with platform-specific definitions may have multiple lids.) There are mappings here + // for active package libraries and for dependency libraries. + constant slot %lids-by-library :: = make(); + + // A map from full absolute pathname of a LID file to the associated . There are + // mappings here for active package libraries and for dependency libraries. + constant slot %lids-by-pathname ::
+ //= make(); // works, but not correct + //= iff(os/$os-name == #"win32", make(), make()); // slot is set to #f! + = if (os/$os-name == #"win32") make() else make() end; // works + + // A map from active package to a sequence of s it contains. + constant slot %lids-by-active-package ::
= make(
); + + // Prevent infinite recursion when scanning a workspace that has no active packages. + slot active-packages-scanned? :: = #f; end class; -define function workspace-registry-directory +define function lids-by-library + (ws :: ) => (t :: ) + if (ws.%lids-by-library.empty?) + scan-workspace(ws); + end; + ws.%lids-by-library +end function; + +define function lids-by-pathname + (ws :: ) => (t ::
) + if (ws.%lids-by-pathname.empty?) + scan-workspace(ws); + end; + ws.%lids-by-pathname +end function; + +define function lids-by-active-package + (ws :: ) => (t ::
) + if (~ws.active-packages-scanned?) + scan-workspace(ws) + end; + ws.%lids-by-active-package +end function; + +define function registry-directory (ws :: ) => (dir :: ) - let registry = ws.workspace-registry; - subdirectory-locator(registry.root-directory, "registry") + subdirectory-locator(ws.workspace-directory, "registry") end function; -// Loads the workspace definition by looking up from `directory` to find the -// workspace root and loading the workspace.json file. If no workspace.json -// file exists, the workspace is created using the dylan-package.json file (if -// any) and default values. As a last resort `directory` is used as the -// workspace root. Signals `` if either JSON file is found but -// is invalid. +// Loads the workspace definition by looking up from `directory` to find the workspace +// root and loading the workspace.json file. If no workspace.json file exists, the +// workspace is created using the dylan-package.json file (if any) and default values. As +// a last resort `directory` is used as the workspace root. Signals `` +// if either JSON file is found but is invalid. define function load-workspace (#key directory :: = fs/working-directory()) => (workspace :: ) @@ -136,37 +105,95 @@ define function load-workspace | workspace-error("Can't find %s or %s. Not inside a workspace?", $workspace-file-name, $dylan-package-file-name); let ws-dir = locator-directory(ws-file | dp-file); - let registry = make(, root-directory: ws-dir); let active-packages = find-active-packages(ws-dir); - let ws-json = ws-file & load-json-file(ws-file); - let default-library - = ws-json & element(ws-json, $default-library-key, default: #f); - if (~default-library) - let libs = find-library-names(registry); - if (~empty?(libs)) - local method match (suffix, lib) - ends-with?(lib, suffix) & lib - end; - // The assumption here is that (for small projects) there's usually one - // test library that you want to run. - default-library := (any?(curry(match, "-test-suite-app"), libs) - | any?(curry(match, "-test-suite"), libs) - | any?(curry(match, "-tests"), libs) - | libs[0]); - end; + let ws = make(, + directory: ws-dir, + active-packages: active-packages, + multi-package?: (active-packages.size > 1 + | (ws-file + & dp-file + & (ws-file.locator-directory ~= dp-file.locator-directory)))); + ws-file & load-workspace-config(ws, ws-file); + ws +end function; + +// Scan the workspace to find all active packages, from which the lids-by-* tables are +// populated and deps can be determined. +define function scan-workspace + (ws :: ) => () + // First do active packages to populate %lids-by-active-package. + for (package in find-active-packages(ws.workspace-directory)) + let directory = active-package-directory(ws, package); + fs/do-directory(curry(scan-workspace-file, ws, package), directory); end; - make(, - active-packages: active-packages, - directory: ws-dir, - registry: registry, - release: dp-file & pm/load-dylan-package-file(dp-file), - default-library-name: default-library, - multi-package?: ws-file - & dp-file - & (ws-file.locator-directory ~= dp-file.locator-directory)) + ws.active-packages-scanned? := #t; // Prevent infinite recursion in empty workspaces. + // Install dependencies and further update the %lids-by-* tables with them. + let (releases, actives) = ensure-deps-installed(ws); + for (release in releases) + let directory = active-package-directory(ws, pm/release-package(release)); + fs/do-directory(curry(scan-workspace-file, ws, release), directory); + end; +end function; + +define function scan-workspace-file + (ws, active-package, dir, name, type) => () + select (type) + #"file" => + let lid-path = file-locator(dir, name); + if (~element(ws.%lids-by-pathname, as(, lid-path), default: #f)) + let comparator = iff(os/$os-name == #"win32", char-compare-ic, char-compare); + select (name by rcurry(ends-with?, test: comparator)) + ".lid", ".hdp" => + ingest-lid-file(ws, active-package, lid-path); + ".spec" => + ingest-spec-file(ws, active-package, lid-path); + otherwise + => #f; + end; + end; + #"directory" => + // TODO: Git submodules could indicate a project in transition from Git + // submodules to Deft, or they could indicate use of a repository that isn't + // available in the package catalog. Ignore them and assume all packages are + // available in the catalog for now. Ultimately we should have an escape hatch + // like the ability to use a local package catalog IN ADDITION to the main + // catalog. Or just make this configurable? + let subdir = subdirectory-locator(dir, name); + let subdir/git = subdirectory-locator(subdir, ".git"); + if (name ~= ".git" & ~fs/file-exists?(subdir/git)) + fs/do-directory(curry(scan-workspace-file, ws, active-package), subdir); + end; + #"link" => + #f; + end select; +end function; + +// Load the workspace.json file +define function load-workspace-config + (ws :: , file :: ) => () + local method find-default-library () + block (return) + let fallback = #f; + for (lids keyed-by package in ws.lids-by-active-package) + for (lid in lids) + let name = lid.library-name; + fallback := fallback | name; + if (ends-with?(name, "-test-suite-app") + | ends-with?(name, "-test-suite") + | ends-with?(name, "-tests")) + return(name); + end; + end for; + end for; + fallback + end block; + end method; + let json = load-json-file(file); + ws.workspace-default-library-name + := element(json, $default-library-key, default: #f) | find-default-library(); end function; -define function load-json-file (file :: ) => (config :: false-or(
)) +define function load-json-file (file :: ) => (config ::
) fs/with-open-file(stream = file, if-does-not-exist: #f) let object = parse-json(stream, strict?: #f, table-class: ); if (~instance?(object,
)) @@ -200,6 +227,12 @@ define function find-dylan-package-file | find-file-in-or-above(directory, as(, $pkg-file-name)) end function; +define function current-dylan-package + (directory :: ) => (p :: false-or(pm/)) + let dp-file = find-dylan-package-file(directory); + dp-file & pm/load-dylan-package-file(dp-file) +end function; + // Return the nearest file or directory with the given `name` in or above // `directory`. `name` is expected to be a locator with an empty path // component. @@ -224,52 +257,63 @@ define function find-file-in-or-above end end function; -// Find `directory`/*/dylan-package.json or `directory`/dylan-package.json and -// turn them/it into a sequence of package `` objects. In other words, -// `directory` is expected to be the workspace root directory. +// Look for dylan-package.json or */dylan-package.json relative to the workspace +// directory and turn it/them into a sequence of `` objects. define function find-active-packages (directory :: ) => (pkgs :: ) - let dpkg-file = file-locator(directory, $dylan-package-file-name); - let pkg-file = file-locator(directory, $pkg-file-name); - if (fs/file-exists?(dpkg-file)) - vector(pm/load-dylan-package-file(dpkg-file)) - elseif (fs/file-exists?(pkg-file)) - vector(pm/load-dylan-package-file(pkg-file)) - else - let packages = make(); - for (locator in fs/directory-contents(directory)) - if (instance?(locator, )) - let loc = file-locator(locator, $dylan-package-file-name); - let loc2 = file-locator(locator, $pkg-file-name); - if (fs/file-exists?(loc)) - let pkg = pm/load-dylan-package-file(loc); - add!(packages, pkg); - elseif (fs/file-exists?(loc2)) - warn("Please rename %s to %s; support for %= will be" - " removed soon.", loc2, $dylan-package-file-name, $pkg-file-name); - let pkg = pm/load-dylan-package-file(loc2); - add!(packages, pkg); - end; - end; - end; - packages - end + let subdir-files + = collecting () + for (locator in fs/directory-contents(directory)) + if (instance?(locator, )) + let dpkg = file-locator(locator, $dylan-package-file-name); + let pkg = file-locator(locator, $pkg-file-name); + if (fs/file-exists?(dpkg)) + collect(dpkg); + elseif (fs/file-exists?(pkg)) + warn("Please rename %s to %s; support for %= will be" + " removed soon.", pkg, $dylan-package-file-name, $pkg-file-name); + collect(pkg); + end; + end; + end for; + end collecting; + local method check-file (file, warn-obsolete?) + if (fs/file-exists?(file)) + if (~empty?(subdir-files)) + warn("Workspace has both a top-level package file (%s) and" + " packages in subdirectories (%s). The latter will be ignored.", + file, join(map(curry(as, ), subdir-files), ", ")); + end; + if (warn-obsolete?) + warn("Please rename %s to %s; support for %= will be" + " removed soon.", file, $dylan-package-file-name, $pkg-file-name); + end; + vector(pm/load-dylan-package-file(file)) + end + end method; + check-file(file-locator(directory, $dylan-package-file-name), #f) + | check-file(file-locator(directory, $pkg-file-name), #t) + | map(pm/load-dylan-package-file, subdir-files) end function; -define function active-package-names - (ws :: ) => (names :: ) - map(pm/package-name, ws.workspace-active-packages) -end function; +define method active-package-directory + (ws :: , package :: pm/) => (d :: ) + active-package-directory(ws, pm/package-name(package)) +end method; + +define method active-package-directory + (ws :: , package :: pm/) => (d :: ) + active-package-directory(ws, pm/package-name(package)) +end method; -// These next three should probably have methods on (, ) too. -define function active-package-directory +define method active-package-directory (ws :: , pkg-name :: ) => (d :: ) if (ws.multi-package-workspace?) subdirectory-locator(ws.workspace-directory, pkg-name) else ws.workspace-directory end -end function; +end method; define function active-package-file (ws :: , pkg-name :: ) => (f :: ) @@ -285,15 +329,16 @@ end function; define function active-package? (ws :: , pkg-name :: ) => (_ :: ) - member?(pkg-name, ws.active-package-names, test: string-equal-ic?) + member?(pkg-name, ws.workspace-active-packages, + test: method (name, package) + string-equal-ic?(name, pm/package-name(package)) + end) end function; // Resolve active package dependencies and install them. -define function update-deps - (ws :: , cat :: pm/) - => (releases :: , actives :: ) - let (releases, actives) = find-active-package-deps(ws, cat, dev?: #t); - // Install dependencies to ${DYLAN}/pkg. +define function ensure-deps-installed + (ws :: ) => (releases :: , actives :: ) + let (releases, actives) = find-active-package-deps(ws, pm/catalog(), dev?: #t); for (release in releases) if (~element(actives, release.pm/package-name, default: #f)) pm/install(release, deps?: #f, force?: #f, actives: actives); @@ -312,18 +357,14 @@ define function find-active-package-deps // Dev deps could go into deps, above, but they're kept separate so that // pacman can give more specific error messages. let dev-deps = make(); - for (pkg-name in ws.active-package-names) - let rel = pm/load-dylan-package-file(active-package-file(ws, pkg-name)); - // active-package-names wouldn't include the release if it didn't have a - // package file. - assert(rel); - actives[pkg-name] := rel; - for (dep in rel.pm/release-dependencies) - add-new!(deps, dep) + for (lids keyed-by release in ws.lids-by-active-package) + actives[pm/package-name(release)] := release; + for (dep in pm/release-dependencies(release)) + add-new!(deps, dep, test: \=) end; if (dev?) - for (dep in rel.pm/release-dev-dependencies) - add-new!(dev-deps, dep); + for (dep in pm/release-dev-dependencies(release)) + add-new!(dev-deps, dep, test: \=); end; end; end; @@ -332,36 +373,3 @@ define function find-active-package-deps let releases-to-install = pm/resolve-deps(cat, deps, dev-deps, actives); values(releases-to-install, actives) end function; - -// Create/update a single registry directory having an entry for each library -// in each active package and all transitive dependencies. This traverses -// package directories to find .lid files. Note that it assumes that .lid files -// that have no "Platforms:" section are generic, and writes a registry file -// for them (unless they're included in another LID file via the LID: keyword, -// in which case it is assumed they're for inclusion only). -define function update-registry - (ws :: , cat :: pm/, releases :: , actives :: ) - => (r :: ) - let registry = ws.workspace-registry; - for (rel in actives) - update-for-directory(registry, active-package-directory(ws, rel.pm/package-name)); - end; - for (rel in releases) - update-for-directory(registry, pm/source-directory(rel)); - end; - registry -end function; - -// Find the names of all libraries defined in the active packages within the -// workspace `ws`. -define function find-active-package-library-names - (ws :: ) => (names :: ) - let names = #[]; - for (package in find-active-packages(ws.workspace-directory)) - let dir = active-package-directory(ws, pm/package-name(package)); - let more-names = find-library-names(dir); - verbose("Found libraries %= in %s", more-names, dir); - names := concat(names, more-names); - end; - names -end function; From 1403f1d283ce398d711c45a6ef1cc9c1e2fc9504 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sat, 28 Dec 2024 12:00:13 -0500 Subject: [PATCH 04/12] cleanup: put each subcommand into its own file It was a bit arbitrary to put some of the simple commands into simple-commands.dylan. Better to be consistent. --- sources/commands/install.dylan | 34 ++++ sources/commands/list.dylan | 83 ++++++++ sources/commands/new-workspace.dylan | 60 ++++++ sources/commands/simple-commands.dylan | 253 ------------------------- sources/commands/status.dylan | 53 ++++++ sources/commands/version.dylan | 17 ++ sources/deft.lid | 12 +- 7 files changed, 255 insertions(+), 257 deletions(-) create mode 100644 sources/commands/install.dylan create mode 100644 sources/commands/list.dylan create mode 100644 sources/commands/new-workspace.dylan delete mode 100644 sources/commands/simple-commands.dylan create mode 100644 sources/commands/status.dylan create mode 100644 sources/commands/version.dylan diff --git a/sources/commands/install.dylan b/sources/commands/install.dylan new file mode 100644 index 0000000..924ddde --- /dev/null +++ b/sources/commands/install.dylan @@ -0,0 +1,34 @@ +Module: deft +Synopsis: install subcommand + + +define class () + keyword name = "install"; + keyword help = "Install Dylan packages."; +end class; + +define constant $install-subcommand + = make(, + options: list(make(, + // TODO: type: + names: #("version", "v"), + default: "latest", + help: "The version to install."), + make(, + name: "pkg", + repeated?: #t, + help: "Packages to install."))); + +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + for (package-name in get-option-value(subcmd, "pkg")) + let vstring = get-option-value(subcmd, "version"); + let release = pm/find-package-release(pm/catalog(), package-name, vstring) + | begin + note("Package %= not found.", package-name); + abort-command(1); + end; + pm/install(release); + end; +end method; diff --git a/sources/commands/list.dylan b/sources/commands/list.dylan new file mode 100644 index 0000000..7541d56 --- /dev/null +++ b/sources/commands/list.dylan @@ -0,0 +1,83 @@ +Module: deft +Synopsys: list subcommand + + +// TODO: this should show locally installed packages by default, but have a --global +// flag. + +define class () + keyword name = "list"; + keyword help = "List installed Dylan packages."; +end class; + +define constant $list-subcommand + = make(, + options: list(make(, + names: #("all", "a"), + help: "List all packages whether installed" + " or not."))); + +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + list-catalog(all?: get-option-value(subcmd, "all")) +end method; + +// List installed package names, summary, versions, etc. If `all` is +// true, show all packages. Installed and latest versions are shown. +define function list-catalog + (#key all? :: ) + local + // Search for the first '.' that is < maxlen characters from the + // beginning. If not found, elide at the nearest whitespace. + method brief-description (text :: ) + let maxlen = 90; + if (text.size < maxlen) + text + else + let space = #f; + let pos = #f; + iterate loop (p = min(text.size - 1, maxlen)) + case + p <= 0 => #f; + text[p] == '.' => pos := p + 1; + otherwise => + if (whitespace?(text[p]) & (~space | space == p + 1)) + space := p; + end; + loop(p - 1); + end; + end iterate; + case + pos => copy-sequence(text, end: pos); + space => concat(copy-sequence(text, end: space), "..."); + otherwise => text; + end + end if + end method, + method package-< (p1, p2) + p1.pm/package-name < p2.pm/package-name + end; + let cat = pm/catalog(); + let packages = pm/load-all-catalog-packages(cat); + // %8s is to handle versions like 2020.1.0 + note(" %8s %8s %-20s %s", + "Inst.", "Latest", "Package", "Description"); + for (package in sort(packages, test: package-<)) + let name = pm/package-name(package); + let versions = pm/installed-versions(name, head?: #f); + let latest-installed = versions.size > 0 & versions[0]; + let package = pm/find-package(cat, name); + let latest = pm/find-package-release(cat, name, pm/$latest); + if (all? | latest-installed) + note("%c %8s %8s %-20s %s", + iff(latest-installed + & (latest-installed < pm/release-version(latest)), + '!', ' '), + latest-installed | "-", + pm/release-version(latest), + name, + brief-description(pm/package-description(package))); + end; + end; +end function; diff --git a/sources/commands/new-workspace.dylan b/sources/commands/new-workspace.dylan new file mode 100644 index 0000000..fc9d3ef --- /dev/null +++ b/sources/commands/new-workspace.dylan @@ -0,0 +1,60 @@ +Module: deft +Synopsis: new workspace subcommand + + +define class () + keyword name = "workspace"; + keyword help = "Create a new workspace."; +end class; + +define constant $new-workspace-subcommand + = make(, + options: list(make(, + names: #("directory", "d"), + help: "Create the workspace in this directory."), + make(, + name: "name", + help: "Workspace directory name."))); + +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + let name = get-option-value(subcmd, "name"); + let dir = get-option-value(subcmd, "directory"); + new(name, parent-directory: dir & as(, dir)); + 0 +end method; + +// Create a new workspace named `name` under `parent-directory`. If `parent-directory` is +// not supplied use the standard location. +// +// TODO: validate `name` +define function new + (name :: , #key parent-directory :: false-or()) + => (ws :: false-or(ws/)) + let dir = parent-directory | fs/working-directory(); + let ws-dir = subdirectory-locator(dir, name); + let ws-path = file-locator(ws-dir, ws/$workspace-file-name); + let existing = ws/find-workspace-file(dir); + if (existing) + ws/workspace-error("Can't create workspace file %s because it is inside another" + " workspace, %s.", ws-path, existing); + end; + if (fs/file-exists?(ws-path)) + note("Workspace already exists: %s", ws-path); + else + fs/ensure-directories-exist(ws-path); + fs/with-open-file (stream = ws-path, + direction: #"output", if-does-not-exist: #"create", + if-exists: #"error") + format(stream, """ + # Dylan workspace %= + + {} + + """, name); + end; + note("Workspace created: %s", ws-path); + end; + ws/load-workspace(directory: ws-dir) +end function; diff --git a/sources/commands/simple-commands.dylan b/sources/commands/simple-commands.dylan deleted file mode 100644 index c5da827..0000000 --- a/sources/commands/simple-commands.dylan +++ /dev/null @@ -1,253 +0,0 @@ -Module: deft -Synopsis: Various command implementations not big enough to warrant their own file - - -// TODO: put each command in its own file, more or less. Having a bunch of random small -// commands in this file just makes them harder to find. - - -/// deft install - -define class () - keyword name = "install"; - keyword help = "Install Dylan packages."; -end class; - -define constant $install-subcommand - = make(, - options: list(make(, - // TODO: type: - names: #("version", "v"), - default: "latest", - help: "The version to install."), - make(, - name: "pkg", - repeated?: #t, - help: "Packages to install."))); - -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - for (package-name in get-option-value(subcmd, "pkg")) - let vstring = get-option-value(subcmd, "version"); - let release = pm/find-package-release(pm/catalog(), package-name, vstring) - | begin - note("Package %= not found.", package-name); - abort-command(1); - end; - pm/install(release); - end; -end method; - - -/// deft list - -// TODO: this should show locally installed packages by default, but have a --global -// flag. - -define class () - keyword name = "list"; - keyword help = "List installed Dylan packages."; -end class; - -define constant $list-subcommand - = make(, - options: list(make(, - names: #("all", "a"), - help: "List all packages whether installed" - " or not."))); - -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - list-catalog(all?: get-option-value(subcmd, "all")) -end method; - -// List installed package names, summary, versions, etc. If `all` is -// true, show all packages. Installed and latest versions are shown. -define function list-catalog - (#key all? :: ) - local - // Search for the first '.' that is < maxlen characters from the - // beginning. If not found, elide at the nearest whitespace. - method brief-description (text :: ) - let maxlen = 90; - if (text.size < maxlen) - text - else - let space = #f; - let pos = #f; - iterate loop (p = min(text.size - 1, maxlen)) - case - p <= 0 => #f; - text[p] == '.' => pos := p + 1; - otherwise => - if (whitespace?(text[p]) & (~space | space == p + 1)) - space := p; - end; - loop(p - 1); - end; - end iterate; - case - pos => copy-sequence(text, end: pos); - space => concat(copy-sequence(text, end: space), "..."); - otherwise => text; - end - end if - end method, - method package-< (p1, p2) - p1.pm/package-name < p2.pm/package-name - end; - let cat = pm/catalog(); - let packages = pm/load-all-catalog-packages(cat); - // %8s is to handle versions like 2020.1.0 - note(" %8s %8s %-20s %s", - "Inst.", "Latest", "Package", "Description"); - for (package in sort(packages, test: package-<)) - let name = pm/package-name(package); - let versions = pm/installed-versions(name, head?: #f); - let latest-installed = versions.size > 0 & versions[0]; - let package = pm/find-package(cat, name); - let latest = pm/find-package-release(cat, name, pm/$latest); - if (all? | latest-installed) - note("%c %8s %8s %-20s %s", - iff(latest-installed - & (latest-installed < pm/release-version(latest)), - '!', ' '), - latest-installed | "-", - pm/release-version(latest), - name, - brief-description(pm/package-description(package))); - end; - end; -end function; - - -/// deft new workspace - -define class () - keyword name = "workspace"; - keyword help = "Create a new workspace."; -end class; - -define constant $new-workspace-subcommand - = make(, - options: list(make(, - names: #("directory", "d"), - help: "Create the workspace in this directory."), - make(, - name: "name", - help: "Workspace directory name."))); - -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - let name = get-option-value(subcmd, "name"); - let dir = get-option-value(subcmd, "directory"); - new(name, parent-directory: dir & as(, dir)); - 0 -end method; - -// Create a new workspace named `name` under `parent-directory`. If `parent-directory` is -// not supplied use the standard location. -// -// TODO: validate `name` -define function new - (name :: , #key parent-directory :: false-or()) - => (ws :: false-or(ws/)) - let dir = parent-directory | fs/working-directory(); - let ws-dir = subdirectory-locator(dir, name); - let ws-path = file-locator(ws-dir, ws/$workspace-file-name); - let existing = ws/find-workspace-file(dir); - if (existing) - ws/workspace-error("Can't create workspace file %s because it is inside another" - " workspace, %s.", ws-path, existing); - end; - if (fs/file-exists?(ws-path)) - note("Workspace already exists: %s", ws-path); - else - fs/ensure-directories-exist(ws-path); - fs/with-open-file (stream = ws-path, - direction: #"output", if-does-not-exist: #"create", - if-exists: #"error") - format(stream, """ - # Dylan workspace %= - - {} - - """, name); - end; - note("Workspace created: %s", ws-path); - end; - ws/load-workspace(directory: ws-dir) -end function; - - -/// deft status - -// TODO: show active package dependencies and whether or not they're installed. - -define class () - keyword name = "status"; - keyword help = "Display information about the current workspace."; -end class; - -define constant $status-subcommand - = make(, - options: list(make(, // for tooling - name: "directory", - help: "Only show the workspace directory."))); - -// TODO: show settings like default library name. -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - let workspace = ws/load-workspace(); - note("Workspace: %s", ws/workspace-directory(workspace)); - if (get-option-value(subcmd, "directory")) - abort-command(0); - end; - - // Show active package status - // TODO: show current branch name and whether modified and whether ahead of - // upstream (usually but not always origin/master). - let active = ws/workspace-active-packages(workspace); - if (empty?(active)) - note("No active packages."); - else - note("Active packages:"); - for (package in sort(active, test: method (a, b) - pm/package-name(a) < pm/package-name(b) - end)) - let directory = ws/active-package-directory(workspace, pm/package-name(package)); - let command = "git status --untracked-files=no --branch --ahead-behind --short"; - let (status, output) = run(command, working-directory: directory); - let line = split(output, "\n")[0]; - - let command = "git status --porcelain --untracked-files=no"; - let (status, output) = run(command, working-directory: directory); - let dirty = ~whitespace?(output); - - note(" %-25s: %s%s", - pm/package-name(package), line, (dirty & " (dirty)") | ""); - end; - end; - 0 -end method; - - -/// deft version - -define class () - keyword name = "version"; - keyword help = "Display the current version of deft."; -end class; - -define constant $version-subcommand = make(); - -define method execute-subcommand - (parser :: , subcmd :: ) - => (status :: false-or()) - note("%s", $deft-version); - 0 -end method; diff --git a/sources/commands/status.dylan b/sources/commands/status.dylan new file mode 100644 index 0000000..3921a5f --- /dev/null +++ b/sources/commands/status.dylan @@ -0,0 +1,53 @@ +Module: deft +Synopsys: status subcommand + + +// TODO: show active package dependencies and whether or not they're installed. + +define class () + keyword name = "status"; + keyword help = "Display information about the current workspace."; +end class; + +define constant $status-subcommand + = make(, + options: list(make(, // for tooling + name: "directory", + help: "Only show the workspace directory."))); + +// TODO: show settings like default library name. +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + let workspace = ws/load-workspace(); + note("Workspace: %s", ws/workspace-directory(workspace)); + if (get-option-value(subcmd, "directory")) + abort-command(0); + end; + + // Show active package status + // TODO: show current branch name and whether modified and whether ahead of + // upstream (usually but not always origin/master). + let active = ws/workspace-active-packages(workspace); + if (empty?(active)) + note("No active packages."); + else + note("Active packages:"); + for (package in sort(active, test: method (a, b) + pm/package-name(a) < pm/package-name(b) + end)) + let directory = ws/active-package-directory(workspace, pm/package-name(package)); + let command = "git status --untracked-files=no --branch --ahead-behind --short"; + let (status, output) = run(command, working-directory: directory); + let line = split(output, "\n")[0]; + + let command = "git status --porcelain --untracked-files=no"; + let (status, output) = run(command, working-directory: directory); + let dirty = ~whitespace?(output); + + note(" %-25s: %s%s", + pm/package-name(package), line, (dirty & " (dirty)") | ""); + end; + end; + 0 +end method; diff --git a/sources/commands/version.dylan b/sources/commands/version.dylan new file mode 100644 index 0000000..4535873 --- /dev/null +++ b/sources/commands/version.dylan @@ -0,0 +1,17 @@ +Module: deft +Synopsys: version subcommand + + +define class () + keyword name = "version"; + keyword help = "Display the current version of deft."; +end class; + +define constant $version-subcommand = make(); + +define method execute-subcommand + (parser :: , subcmd :: ) + => (status :: false-or()) + note("%s", $deft-version); + 0 +end method; diff --git a/sources/deft.lid b/sources/deft.lid index 1c1f8bc..e166048 100644 --- a/sources/deft.lid +++ b/sources/deft.lid @@ -10,10 +10,14 @@ Files: library.dylan workspaces/lid.dylan workspaces/registry.dylan workspaces/workspaces.dylan - commands/utils.dylan - commands/simple-commands.dylan + commands/build.dylan + commands/command-line.dylan + commands/install.dylan + commands/list.dylan commands/new-library.dylan + commands/new-workspace.dylan commands/publish.dylan - commands/build.dylan + commands/status.dylan commands/update.dylan - commands/command-line.dylan + commands/utils.dylan + commands/version.dylan From 5b91917c50553bd68376bcaa3e08a6a6a9e630a0 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sat, 28 Dec 2024 13:04:59 -0500 Subject: [PATCH 05/12] cleanup: Remove locate-dylan-compiler; assume it's on the PATH What was I thinking? --- sources/commands/build.dylan | 24 +++++++++++++----------- sources/library.dylan | 3 +-- sources/shared.dylan | 19 ------------------- 3 files changed, 14 insertions(+), 32 deletions(-) diff --git a/sources/commands/build.dylan b/sources/commands/build.dylan index 568e6a5..0a81e96 100644 --- a/sources/commands/build.dylan +++ b/sources/commands/build.dylan @@ -54,22 +54,24 @@ define method execute-subcommand | error("No libraries found in workspace and no" " default libraries configured.")); end; - let dylan-compiler = locate-dylan-compiler(); for (name in library-names) // TODO: this should pass -target dll in some cases. - let command = remove(vector(dylan-compiler, - "-compile", - get-option-value(subcmd, "clean") & "-clean", - get-option-value(subcmd, "link") & "-link", - get-option-value(subcmd, "unify") & "-unify", - name), - #f); - debug("Running command %=", command); + // Let the shell locate dylan-compiler... + let command + = join(remove(list("dylan-compiler", + "-compile", + get-option-value(subcmd, "clean") & "-clean", + get-option-value(subcmd, "link") & "-link", + get-option-value(subcmd, "unify") & "-unify", + name), + #f), + " "); + verbose("%s", command); let env = make-compilation-environment(ws); let exit-status = os/run-application(command, - environment: env, // adds to the existing environment - under-shell?: #f, + environment: env, // AUGMENTS the existing environment + under-shell?: #t, working-directory: ws/workspace-directory(ws)); if (exit-status ~== 0) error("Build of %= failed with exit status %=.", name, exit-status); diff --git a/sources/library.dylan b/sources/library.dylan index f971fcf..7ea82b4 100644 --- a/sources/library.dylan +++ b/sources/library.dylan @@ -41,8 +41,7 @@ define module shared note, verbose, trace, - warn, - locate-dylan-compiler; + warn; end module; define module pacman diff --git a/sources/shared.dylan b/sources/shared.dylan index 420dbf0..d1a9f58 100644 --- a/sources/shared.dylan +++ b/sources/shared.dylan @@ -40,22 +40,3 @@ end; define inline function warn (fmt, #rest args) => () apply(note, concat("WARNING: ", fmt), args); end; - - -// Find the full path to dylan-compiler or signal an error. -define function locate-dylan-compiler () => (dc :: ) - let output = with-output-to-string (stream) - local method outputter (output, #key end: epos) - write(stream, copy-sequence(output, end: epos)); - end; - os/run-application("which dylan-compiler", - under-shell?: #t, - outputter: outputter); - end; - let lines = split-lines(output); - if (lines[0].size > 0) - lines[0] - else - error("dylan-compiler not found. Is it on your PATH?"); - end -end function; From 534328e8aa880bb89de28b90ba44cebdbe5257c4 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sun, 29 Dec 2024 09:58:51 -0500 Subject: [PATCH 06/12] cleanup: reduce duplication in module definitions ...by using deft-shared to re-export everything in a way that can be used by the workspaces and pacman modules. --- sources/app-library.dylan | 4 +- sources/library.dylan | 106 +++++++---------------- sources/pacman/install-test.dylan | 8 +- sources/shared.dylan | 2 +- sources/test-suite-library.dylan | 21 ++--- sources/workspaces/workspaces-test.dylan | 2 +- 6 files changed, 44 insertions(+), 99 deletions(-) diff --git a/sources/app-library.dylan b/sources/app-library.dylan index 4ed1ef9..6f70bc0 100644 --- a/sources/app-library.dylan +++ b/sources/app-library.dylan @@ -11,11 +11,11 @@ define library deft-app end library; define module deft-app - use common-dylan; use command-line-parser; + use common-dylan; + use deft-shared; use deft; use format-out; use logging; use operating-system, prefix: "os/"; - use shared; end module; diff --git a/sources/library.dylan b/sources/library.dylan index 7ea82b4..a3a7b10 100644 --- a/sources/library.dylan +++ b/sources/library.dylan @@ -19,21 +19,33 @@ define library deft export deft, - pacman, - %pacman, - shared, - workspaces, - %workspaces; + deft-shared, + pacman, %pacman, + workspaces, %workspaces; end library; -// Definitions used by all the other modules. -define module shared - use format-out; - use operating-system, prefix: "os/"; - use streams; - use strings; - use uncommon-dylan, - exclude: { format-out }; +// Utilities shared by all Deft modules, and also a set of shared imports. +define module deft-shared + use collectors, export: all; + use command-line-parser, export: all; + use date, import: { current-date, }, 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 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; + export *debug?*, *verbose?*, @@ -110,26 +122,8 @@ define module pacman end module; define module %pacman - use date, - import: { current-date, }; - use file-system, prefix: "fs/"; - use format; - use format-out; - use json; - use locators; - use operating-system, prefix: "os/"; - use print; - use regular-expressions; - use shared; - use streams; - use strings; - use uncommon-dylan, - exclude: { format-out, format-to-string }; - // Do we need this? - use uncommon-utils, - import: { elt, iff, , value-sequence }; - - use pacman, export: all; + use deft-shared; + use pacman; // For the test suite. export @@ -175,32 +169,12 @@ define module workspaces end module; define module %workspaces - use collectors; - 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 deft-shared; + use workspaces; 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 standard-io; - use streams; - use strings; - use threads; - use uncommon-dylan, - exclude: { format-out, format-to-string }; - use uncommon-utils, - import: { err, iff, inc!, slice }; - use workspaces; // Exports for the test suite. export @@ -212,29 +186,11 @@ define module %workspaces end module; define module deft - use collectors; - use command-line-parser; - use file-system, prefix: "fs/"; - use format; - use format-out; - use json; - use locators; - use operating-system, prefix: "os/"; + use deft-shared; 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* }; - use regular-expressions; - use shared; - use standard-io; - use streams; - use strings; - use threads, - import: { dynamic-bind }; - use uncommon-dylan, - exclude: { format-out, format-to-string }; - use uncommon-utils, - import: { err, iff, inc!, slice }; use workspaces, prefix: "ws/"; export diff --git a/sources/pacman/install-test.dylan b/sources/pacman/install-test.dylan index 995d8b6..58da4fa 100644 --- a/sources/pacman/install-test.dylan +++ b/sources/pacman/install-test.dylan @@ -12,19 +12,19 @@ define test test-install (tags: #["net"]) versions: #("1.0.0"), catalog: cat); let release = find-package-release(cat, "json", $latest); - let saved-dylan = environment-variable($dylan-env-var); + let saved-dylan = os/environment-variable($dylan-env-var); block () - environment-variable($dylan-env-var) := as(, dir); + os/environment-variable($dylan-env-var) := as(, dir); assert-false(installed?(release)); install(release); assert-true(installed?(release)); let lid-path = file-locator(dir, $package-directory-name, "json", "1.0.0", "src", "json.lid"); - assert-true(file-exists?(lid-path)); + assert-true(fs/file-exists?(lid-path)); let versions = installed-versions(release.package-name); assert-equal(1, size(versions)); assert-equal(map-as(, identity, versions), list(release.release-version)); cleanup - environment-variable($dylan-env-var) := saved-dylan; + os/environment-variable($dylan-env-var) := saved-dylan; end; end test; diff --git a/sources/shared.dylan b/sources/shared.dylan index d1a9f58..b8cf102 100644 --- a/sources/shared.dylan +++ b/sources/shared.dylan @@ -1,4 +1,4 @@ -Module: shared +Module: deft-shared // Whether to do verbose output. This is set based on the --verbose command diff --git a/sources/test-suite-library.dylan b/sources/test-suite-library.dylan index f74bed0..a88eff6 100644 --- a/sources/test-suite-library.dylan +++ b/sources/test-suite-library.dylan @@ -1,28 +1,17 @@ Module: dylan-user define library deft-test-suite - use common-dylan; - use deft; - use io; - use strings; - use system; use testworks; + + use deft; end library; define module deft-test-suite - use common-dylan; - use file-system; - use format; - use locators; - use operating-system; + use testworks; + + use deft-shared; // where we get the dylan module from use pacman; use %pacman; - use shared; - use standard-io; - use streams; - use strings; - use testworks; - use threads; use workspaces; use %workspaces; end module; diff --git a/sources/workspaces/workspaces-test.dylan b/sources/workspaces/workspaces-test.dylan index 726af67..0e10b24 100644 --- a/sources/workspaces/workspaces-test.dylan +++ b/sources/workspaces/workspaces-test.dylan @@ -7,7 +7,7 @@ define test test-find-workspace-directory () let ws = file-locator(tmp, $workspace-file-name); let dp = file-locator(tmp, "dp", $dylan-package-file-name); let bottom = subdirectory-locator(tmp, "dp", "abc", "xyz"); - ensure-directories-exist(bottom); + fs/ensure-directories-exist(bottom); // Initially there is no workspace directory. let ws-dir = find-workspace-directory(bottom); From c3e89e2fc2262ac54f8ef0a260c8d155c856b698 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Sun, 29 Dec 2024 13:39:13 -0500 Subject: [PATCH 07/12] cleanup: remove submodules and simplify the Makefile It's easy to forget to keep the submodules up-to-date with dylan-package.json and not really worth the continuing trouble. If we need to build Deft on a new platform it's just not that hard to checkout the dependencies and make the registry. * Ran into trouble with unified exe not finding libunwind.so so I've reverted back to the non-unified build and install regime until we have a new release with housel's fix for libunwind (likely 2025.1). * Removed the source controlled registry files, which were for building with submodules. * Removed the hack to add the Git version info to `$deft-version`; that will be handled with Git filters in a subsequent commit. --- .github/workflows/build-and-test.yml | 8 ++ .gitmodules | 24 ------ Makefile | 75 ++++++++----------- dylan-package.json | 8 +- ext/command-line-parser | 1 - ext/json | 1 - ext/logging | 1 - ext/pacman-catalog | 1 - ext/regular-expressions | 1 - ext/sphinx-extensions | 1 - ext/testworks | 1 - ext/uncommon-dylan | 1 - registry/generic/command-line-parser | 1 - .../generic/command-line-parser-test-suite | 1 - .../command-line-parser-test-suite-app | 1 - registry/generic/deft | 1 - registry/generic/deft-app | 1 - registry/generic/deft-test-suite | 1 - registry/generic/json | 1 - registry/generic/json-test-suite | 1 - registry/generic/logging | 1 - registry/generic/logging-test-suite | 1 - registry/generic/regular-expressions | 1 - .../generic/regular-expressions-test-suite | 1 - registry/generic/testworks | 1 - registry/generic/uncommon-dylan | 1 - registry/generic/uncommon-dylan-tests | 1 - 27 files changed, 45 insertions(+), 93 deletions(-) delete mode 160000 ext/command-line-parser delete mode 160000 ext/json delete mode 160000 ext/logging delete mode 160000 ext/pacman-catalog delete mode 160000 ext/regular-expressions delete mode 160000 ext/sphinx-extensions delete mode 160000 ext/testworks delete mode 160000 ext/uncommon-dylan delete mode 100644 registry/generic/command-line-parser delete mode 100644 registry/generic/command-line-parser-test-suite delete mode 100644 registry/generic/command-line-parser-test-suite-app delete mode 100644 registry/generic/deft delete mode 100644 registry/generic/deft-app delete mode 100644 registry/generic/deft-test-suite delete mode 100644 registry/generic/json delete mode 100644 registry/generic/json-test-suite delete mode 100644 registry/generic/logging delete mode 100644 registry/generic/logging-test-suite delete mode 100644 registry/generic/regular-expressions delete mode 100644 registry/generic/regular-expressions-test-suite delete mode 100644 registry/generic/testworks delete mode 100644 registry/generic/uncommon-dylan delete mode 100644 registry/generic/uncommon-dylan-tests diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index 4c9dc4d..f0d74bf 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -55,3 +55,11 @@ jobs: ${exe} list ${exe} build abc-test-suite _build/bin/abc-test-suite + + - name: Run test suite using submodules + env: + DYLAN_CATALOG: ext/pacman-catalog + DYLAN: dylan-root + run: | + mkdir -p ${DYLAN} + make test-submodules diff --git a/.gitmodules b/.gitmodules index 0903775..e69de29 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,24 +0,0 @@ -[submodule "ext/sphinx-extensions"] - path = ext/sphinx-extensions - url = https://github.com/dylan-lang/sphinx-extensions.git -[submodule "ext/command-line-parser"] - path = ext/command-line-parser - url = https://github.com/dylan-lang/command-line-parser -[submodule "ext/json"] - path = ext/json - url = https://github.com/dylan-lang/json -[submodule "ext/logging"] - path = ext/logging - url = https://github.com/dylan-lang/logging -[submodule "ext/regular-expressions"] - path = ext/regular-expressions - url = https://github.com/dylan-lang/regular-expressions -[submodule "ext/uncommon-dylan"] - path = ext/uncommon-dylan - url = https://github.com/cgay/uncommon-dylan -[submodule "ext/testworks"] - path = ext/testworks - url = https://github.com/dylan-lang/testworks -[submodule "ext/pacman-catalog"] - path = ext/pacman-catalog - url = https://github.com/dylan-lang/pacman-catalog diff --git a/Makefile b/Makefile index cde1aa6..af7ede1 100644 --- a/Makefile +++ b/Makefile @@ -1,64 +1,55 @@ # Low-tech Makefile to build and install deft. DYLAN ?= $${HOME}/dylan -install_dir = $(DYLAN)/install/deft -install_bin = $(install_dir)/bin -install_lib = $(install_dir)/lib -link_target = $(install_bin)/deft-app -link_source = $(DYLAN)/bin/dylan -git_version := "$(shell git describe --tags --always --match 'v*')" +.PHONY: build clean install remove-deft-artifacts test dist distclean -.PHONY: build build-with-version clean install install-debug really-install remove-deft-artifacts test dist distclean +git_version := $(shell git describe --tags --always --match 'v*') -build: remove-deft-artifacts - OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry dylan-compiler -build -unify deft-app - -# Hack to add the version to the binary with git tag info. Don't want this to -# be the normal build because it causes unnecessary rebuilds. -build-with-version: remove-deft-artifacts +# Hack to add the version to the binary with Git tag info. During development I (cgay) +# just build with "deft build" so the unnecessary rebuilds that this would cause aren't +# an issue. +build: + dylan update file="sources/commands/utils.dylan"; \ orig=$$(mktemp); \ temp=$$(mktemp); \ cp -p $${file} $${orig}; \ - cat $${file} | sed "s,/.__./.*/.__./,/*__*/ \"${git_version}\" /*__*/,g" > $${temp}; \ + cat $${file} | sed "s,/.__./.*/.__./,/*__*/ \"${git_version}\ built on $$(date -Iseconds)\" /*__*/,g" > $${temp}; \ mv $${temp} $${file}; \ - OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry \ - dylan-compiler -build -unify deft-app; \ + OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry dylan-compiler -build deft-app; \ cp -p $${orig} $${file} -# Until the install-deft GitHub Action is no longer referring to deft-app -# we also create a link named deft-app. -really-install: +install: build mkdir -p $(DYLAN)/bin - cp _build/sbin/deft-app $(DYLAN)/bin/deft - ln -f $(DYLAN)/bin/deft $(DYLAN)/bin/deft-app - ln -f $(DYLAN)/bin/deft $(DYLAN)/bin/dylan - -install: build-with-version really-install - -# Build and install without the version hacking above. -install-debug: build really-install - -# Deft needs to be buildable with submodules so that it can be built on -# new platforms without having to manually install deps. -test: build - OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry \ - dylan-compiler -build deft-test-suite \ - && DYLAN_CATALOG=ext/pacman-catalog _build/bin/deft-test-suite + mkdir -p $(DYLAN)/install/deft/bin + mkdir -p $(DYLAN)/install/deft/lib + cp _build/bin/deft-app $(DYLAN)/install/deft/bin/deft + cp -r _build/lib/lib* $(DYLAN)/install/deft/lib/ + # For unified exe these could be hard links but for now they must be symlinks so + # that the relative paths to ../lib are correct. With --unify I ran into the + # "libunwind.so not found" bug. + ln -s -f $$(realpath $(DYLAN)/install/deft/bin/deft) $(DYLAN)/bin/deft + # For temp backward compatibility... + ln -s -f $$(realpath $(DYLAN)/install/deft/bin/deft) $(DYLAN)/bin/deft-app + ln -s -f $$(realpath $(DYLAN)/install/deft/bin/deft) $(DYLAN)/bin/dylan + +test: + dylan update + OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry dylan-compiler -build deft-test-suite \ + && _build/bin/deft-test-suite dist: distclean install -# Sometimes I use deft to develop deft, so this makes sure to clean -# up its artifacts. -remove-deft-artifacts: +clean: rm -rf _packages - find registry -not -path '*/generic/*' -type f -exec rm {} \; - -clean: remove-deft-artifacts + rm -rf registry rm -rf _build rm -rf _test + rm -rf *~ distclean: clean - rm -rf $(install_dir) - rm -f $(link_source) + rm -rf $(DYLAN)/install/deft + rm $(DYLAN)/bin/deft + rm $(DYLAN)/bin/deft-app + rm $(DYLAN)/bin/dylan diff --git a/dylan-package.json b/dylan-package.json index e794377..1103461 100644 --- a/dylan-package.json +++ b/dylan-package.json @@ -1,15 +1,15 @@ { "name": "deft", - "version": "0.12.0", + "version": "0.13.0", "license": "MIT", - "category": "language-tools", + "category": "development tools", "contact": "dylan-lang@googlegroups.com", "description": "Manage Dylan workspaces, packages, and registries", "keywords": ["workspace", "package"], "dependencies": [ "command-line-parser@3.1.1", - "json@1.0", - "logging@2.1", + "json@1.1", + "logging@2.2", "regular-expressions@0.2", "uncommon-dylan@0.2" ], diff --git a/ext/command-line-parser b/ext/command-line-parser deleted file mode 160000 index 4e73ed6..0000000 --- a/ext/command-line-parser +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 4e73ed605f09e8ad605ef53d49583f5985489d4d diff --git a/ext/json b/ext/json deleted file mode 160000 index d6dabb6..0000000 --- a/ext/json +++ /dev/null @@ -1 +0,0 @@ -Subproject commit d6dabb6e48fcc13c08e5725813f394af7c590986 diff --git a/ext/logging b/ext/logging deleted file mode 160000 index e0e87fa..0000000 --- a/ext/logging +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e0e87fa7cecc0008a3896df30e622d3dc8586e87 diff --git a/ext/pacman-catalog b/ext/pacman-catalog deleted file mode 160000 index 8b4088a..0000000 --- a/ext/pacman-catalog +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 8b4088a4a04072e5e636f151be20f33387e61f9b diff --git a/ext/regular-expressions b/ext/regular-expressions deleted file mode 160000 index 5fd7d35..0000000 --- a/ext/regular-expressions +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5fd7d3567510949ca41e3540412f3fcc527fb098 diff --git a/ext/sphinx-extensions b/ext/sphinx-extensions deleted file mode 160000 index 05804f1..0000000 --- a/ext/sphinx-extensions +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 05804f14913ea7cbd1ce6c7d0d7b540dbaae8ca6 diff --git a/ext/testworks b/ext/testworks deleted file mode 160000 index c149c1a..0000000 --- a/ext/testworks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c149c1ae37473d4076e23063d63521283915ca00 diff --git a/ext/uncommon-dylan b/ext/uncommon-dylan deleted file mode 160000 index 440a3b9..0000000 --- a/ext/uncommon-dylan +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 440a3b9af72dd71e77313f7ee1216ed061014e91 diff --git a/registry/generic/command-line-parser b/registry/generic/command-line-parser deleted file mode 100644 index cfd0a04..0000000 --- a/registry/generic/command-line-parser +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/command-line-parser/command-line-parser.lid diff --git a/registry/generic/command-line-parser-test-suite b/registry/generic/command-line-parser-test-suite deleted file mode 100644 index 7911978..0000000 --- a/registry/generic/command-line-parser-test-suite +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/command-line-parser/tests/command-line-parser-test-suite.lid diff --git a/registry/generic/command-line-parser-test-suite-app b/registry/generic/command-line-parser-test-suite-app deleted file mode 100644 index b5fc802..0000000 --- a/registry/generic/command-line-parser-test-suite-app +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/command-line-parser/tests/command-line-parser-test-suite-app.lid diff --git a/registry/generic/deft b/registry/generic/deft deleted file mode 100644 index 52e8cc8..0000000 --- a/registry/generic/deft +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/sources/deft.lid diff --git a/registry/generic/deft-app b/registry/generic/deft-app deleted file mode 100644 index 215f994..0000000 --- a/registry/generic/deft-app +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/sources/deft-app.lid diff --git a/registry/generic/deft-test-suite b/registry/generic/deft-test-suite deleted file mode 100644 index 0ca1ddb..0000000 --- a/registry/generic/deft-test-suite +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/sources/test-suite.lid diff --git a/registry/generic/json b/registry/generic/json deleted file mode 100644 index 0b78401..0000000 --- a/registry/generic/json +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/json/json.lid diff --git a/registry/generic/json-test-suite b/registry/generic/json-test-suite deleted file mode 100644 index 0562a62..0000000 --- a/registry/generic/json-test-suite +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/json/tests/json-test-suite.lid diff --git a/registry/generic/logging b/registry/generic/logging deleted file mode 100644 index b501702..0000000 --- a/registry/generic/logging +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/logging/logging.lid diff --git a/registry/generic/logging-test-suite b/registry/generic/logging-test-suite deleted file mode 100644 index d022ec6..0000000 --- a/registry/generic/logging-test-suite +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/logging/tests/logging-test-suite.lid diff --git a/registry/generic/regular-expressions b/registry/generic/regular-expressions deleted file mode 100644 index bbd9501..0000000 --- a/registry/generic/regular-expressions +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/regular-expressions/regular-expressions.lid diff --git a/registry/generic/regular-expressions-test-suite b/registry/generic/regular-expressions-test-suite deleted file mode 100644 index dd939cf..0000000 --- a/registry/generic/regular-expressions-test-suite +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/regular-expressions/tests/regular-expressions-test-suite.lid diff --git a/registry/generic/testworks b/registry/generic/testworks deleted file mode 100644 index d9385bf..0000000 --- a/registry/generic/testworks +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/testworks/testworks.lid diff --git a/registry/generic/uncommon-dylan b/registry/generic/uncommon-dylan deleted file mode 100644 index 029d7fa..0000000 --- a/registry/generic/uncommon-dylan +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/uncommon-dylan/uncommon-dylan.lid diff --git a/registry/generic/uncommon-dylan-tests b/registry/generic/uncommon-dylan-tests deleted file mode 100644 index 25ce766..0000000 --- a/registry/generic/uncommon-dylan-tests +++ /dev/null @@ -1 +0,0 @@ -abstract://dylan/ext/uncommon-dylan/tests/uncommon-dylan-tests.lid From 3b389110b2827f61b560a88d524faa416ec3bad2 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 30 Dec 2024 12:01:20 -0500 Subject: [PATCH 08/12] automation: ensure that env var paths are absolute ...by using less GitHub-specific technology. Rather than using the 'env' config just set variables in the shell script. There's probably a way to DTRT with 'env', but why bother. --- .github/workflows/build-and-test.yml | 33 ++++++++-------------------- 1 file changed, 9 insertions(+), 24 deletions(-) diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index f0d74bf..8edb1fb 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -26,40 +26,25 @@ jobs: - uses: dylan-lang/install-opendylan@v3 - name: Build and run test suite - env: - DYLAN_CATALOG: ext/pacman-catalog - DYLAN: dylan-root run: | + export DYLAN="$(realpath dylan-root)" mkdir -p ${DYLAN} make test - name: Install - env: - DYLAN_CATALOG: ext/pacman-catalog - DYLAN: dylan-root run: | + export DYLAN="$(realpath dylan-root)" mkdir -p ${DYLAN} make install - name: Exercise deft - env: - DYLAN_CATALOG: ext/pacman-catalog - DYLAN: dylan-root run: | - exe="$(realpath ${DYLAN}/bin/deft)" - export DYLAN_CATALOG="$(realpath ${DYLAN_CATALOG})" - ${exe} new library --force-package abc strings@1.1 + export DYLAN="$(realpath dylan-root)" + export PATH="${DYLAN}/bin:${PATH}" + deft new library --force-package abc strings@1.1 cd abc - ${exe} update - ${exe} status - ${exe} list - ${exe} build abc-test-suite + deft update + deft status + deft list + deft build abc-test-suite _build/bin/abc-test-suite - - - name: Run test suite using submodules - env: - DYLAN_CATALOG: ext/pacman-catalog - DYLAN: dylan-root - run: | - mkdir -p ${DYLAN} - make test-submodules From d850352fcb52af1f72686a02384670fa1e6f6aa0 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Mon, 30 Dec 2024 14:07:56 -0500 Subject: [PATCH 09/12] Change how $deft-version is managed. Use the git config filter mechanism instead of a Makefile hack. Each dev needs to run these two commands in the top-level repo directory once per clone: git config filter.version.smudge ./scripts/version-smudge.sh git config filter.version.clean ./scripts/version-clean.sh --- .gitattributes | 5 +++++ Makefile | 18 ++++-------------- scripts/version-clean.sh | 4 ++++ scripts/version-smudge.sh | 6 ++++++ sources/commands/utils.dylan | 16 ++++++---------- 5 files changed, 25 insertions(+), 24 deletions(-) create mode 100644 .gitattributes create mode 100755 scripts/version-clean.sh create mode 100755 scripts/version-smudge.sh diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..8c75f7c --- /dev/null +++ b/.gitattributes @@ -0,0 +1,5 @@ +# To actually use this filter you must run the following commands in the top-level Def directory. +# git config filter.version.smudge ./scripts/version-smudge.sh +# git config filter.version.clean ./scripts/version-clean.sh +# There is no way to configure that for all users of the repo. +sources/commands/utils.dylan filter=version diff --git a/Makefile b/Makefile index af7ede1..46d9f06 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ -# Low-tech Makefile to build and install deft. +# Low-tech Makefile to build and install deft. You will need a working "dylan" binary on +# your PATH somewhere. DYLAN ?= $${HOME}/dylan @@ -6,19 +7,9 @@ DYLAN ?= $${HOME}/dylan git_version := $(shell git describe --tags --always --match 'v*') -# Hack to add the version to the binary with Git tag info. During development I (cgay) -# just build with "deft build" so the unnecessary rebuilds that this would cause aren't -# an issue. build: dylan update - file="sources/commands/utils.dylan"; \ - orig=$$(mktemp); \ - temp=$$(mktemp); \ - cp -p $${file} $${orig}; \ - cat $${file} | sed "s,/.__./.*/.__./,/*__*/ \"${git_version}\ built on $$(date -Iseconds)\" /*__*/,g" > $${temp}; \ - mv $${temp} $${file}; \ - OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry dylan-compiler -build deft-app; \ - cp -p $${orig} $${file} + dylan build deft-app install: build mkdir -p $(DYLAN)/bin @@ -36,8 +27,7 @@ install: build test: dylan update - OPEN_DYLAN_USER_REGISTRIES=${PWD}/registry dylan-compiler -build deft-test-suite \ - && _build/bin/deft-test-suite + dylan build deft-test-suite && _build/bin/deft-test-suite dist: distclean install diff --git a/scripts/version-clean.sh b/scripts/version-clean.sh new file mode 100755 index 0000000..32d24df --- /dev/null +++ b/scripts/version-clean.sh @@ -0,0 +1,4 @@ +#!/bin/bash + +echo "$(date -Iseconds) clean $(pwd)" >> /tmp/version.log +sed "s,\"v.*built on.*\",\"DEVELOPMENT_VERSION\",g" diff --git a/scripts/version-smudge.sh b/scripts/version-smudge.sh new file mode 100755 index 0000000..bc69ede --- /dev/null +++ b/scripts/version-smudge.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +git_version="$(git describe --tags --always --match 'v*')" +date="$(date -Iseconds)" +echo "$(date -Iseconds) smudge $(pwd)" >> /tmp/version.log +sed "s,DEVELOPMENT_VERSION,${git_version} built on ${date},g" diff --git a/sources/commands/utils.dylan b/sources/commands/utils.dylan index 6816e47..8af551c 100644 --- a/sources/commands/utils.dylan +++ b/sources/commands/utils.dylan @@ -2,18 +2,14 @@ Module: deft Synopsis: Utilities for use by deft commands -// The Makefile replaces this string with the actual tagged version before -// building. DON'T MOVE THE /*__*/ MARKERS since they're part of the regex. -// Using the comment markers enables recovery if someone commits a string -// other than "HEAD" by accident. git's `ident` attribute doesn't use tag -// names and `filter` looks more complex than it's worth. -define constant $deft-version :: = /*__*/ "HEAD" /*__*/; +// This string is replaced by Git filters on checkout. See the .gitattributes file. +define constant $deft-version :: = "DEVELOPMENT_VERSION"; -// Run an executable or shell command. `command` may be a string or a sequence -// of strings. If a string it is run with `/bin/sh -c`. If a sequence of -// strings the first element is the executable pathname. Returns the exit -// status of the command and the combined output to stdout and stderr. +// Run an executable or shell command. `command` may be a string or a sequence of +// strings. If a string it is run with `/bin/sh -c`. If a sequence of strings the first +// element is the executable pathname. Returns the exit status of the command and the +// combined output to stdout and stderr. define function run (command :: , #key working-directory :: false-or()) => (status :: , output :: ) From 19170bedd51b19cfceb583c2e7f54aa97ed35fea Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Tue, 31 Dec 2024 15:52:56 -0500 Subject: [PATCH 10/12] cleanup: Makefile --- Makefile | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 46d9f06..6f0d57c 100644 --- a/Makefile +++ b/Makefile @@ -5,8 +5,6 @@ DYLAN ?= $${HOME}/dylan .PHONY: build clean install remove-deft-artifacts test dist distclean -git_version := $(shell git describe --tags --always --match 'v*') - build: dylan update dylan build deft-app @@ -40,6 +38,6 @@ clean: distclean: clean rm -rf $(DYLAN)/install/deft - rm $(DYLAN)/bin/deft - rm $(DYLAN)/bin/deft-app - rm $(DYLAN)/bin/dylan + rm -f $(DYLAN)/bin/deft + rm -f $(DYLAN)/bin/deft-app + rm -f $(DYLAN)/bin/dylan From 87d1bce76322a14223be8f32a1a6b3a26bfb9385 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Tue, 31 Dec 2024 16:03:15 -0500 Subject: [PATCH 11/12] cleanup: move some general-purpose functions to deft-shared module --- sources/library.dylan | 8 +++----- sources/shared.dylan | 23 +++++++++++++++++++++++ sources/workspaces/registry.dylan | 13 ------------- sources/workspaces/workspaces.dylan | 10 ---------- 4 files changed, 26 insertions(+), 28 deletions(-) diff --git a/sources/library.dylan b/sources/library.dylan index a3a7b10..8708df7 100644 --- a/sources/library.dylan +++ b/sources/library.dylan @@ -49,11 +49,9 @@ define module deft-shared export *debug?*, *verbose?*, - debug, - note, - verbose, - trace, - warn; + debug, note, verbose, trace, warn, + file-content, + load-json-file; end module; define module pacman diff --git a/sources/shared.dylan b/sources/shared.dylan index b8cf102..4cf7664 100644 --- a/sources/shared.dylan +++ b/sources/shared.dylan @@ -40,3 +40,26 @@ end; define inline function warn (fmt, #rest args) => () apply(note, concat("WARNING: ", fmt), args); end; + +define function load-json-file (file :: ) => (config ::
) + fs/with-open-file(stream = file, if-does-not-exist: #f) + let object = parse-json(stream, strict?: #f, table-class: ); + if (~instance?(object,
)) + error("Invalid JSON file %s, must contain at least {}", file); + end; + object + end +end function; + +// Read the full contents of a file and return it as a string. If the file +// doesn't exist return #f. (I thought if-does-not-exist: #f was supposed to +// accomplish this without the need for block/exception.) +define function file-content (path :: ) => (text :: false-or()) + block () + fs/with-open-file(stream = path, if-does-not-exist: #"signal") + read-to-end(stream) + end + exception (fs/) + #f + end +end function; diff --git a/sources/workspaces/registry.dylan b/sources/workspaces/registry.dylan index 9e5eabe..bc58aea 100644 --- a/sources/workspaces/registry.dylan +++ b/sources/workspaces/registry.dylan @@ -39,19 +39,6 @@ define function write-registry-file end end function; -// Read the full contents of a file and return it as a string. If the file -// doesn't exist return #f. (I thought if-does-not-exist: #f was supposed to -// accomplish this without the need for block/exception.) -define function file-content (path :: ) => (text :: false-or()) - block () - fs/with-open-file(stream = path, if-does-not-exist: #"signal") - read-to-end(stream) - end - exception (fs/) - #f - end -end function; - // Create/update a single registry directory having an entry for each library // in each active package and all transitive dependencies. This traverses // package directories to find .lid files. Note that it assumes that .lid files diff --git a/sources/workspaces/workspaces.dylan b/sources/workspaces/workspaces.dylan index 2d57049..c98c34c 100644 --- a/sources/workspaces/workspaces.dylan +++ b/sources/workspaces/workspaces.dylan @@ -193,16 +193,6 @@ define function load-workspace-config := element(json, $default-library-key, default: #f) | find-default-library(); end function; -define function load-json-file (file :: ) => (config ::
) - fs/with-open-file(stream = file, if-does-not-exist: #f) - let object = parse-json(stream, strict?: #f, table-class: ); - if (~instance?(object,
)) - workspace-error("Invalid JSON file %s, must contain at least {}", file); - end; - object - end -end function; - // Find the workspace directory. The nearest directory containing // workspace.json always takes precedence. Otherwise the nearest directory // containing dylan-package.json. From 4a0ae00cb7edad04205a672679589e5e4d451129 Mon Sep 17 00:00:00 2001 From: Carl Gay Date: Wed, 1 Jan 2025 08:59:17 -0500 Subject: [PATCH 12/12] cleanup: remove a pointless TODO --- sources/commands/build.dylan | 1 - 1 file changed, 1 deletion(-) diff --git a/sources/commands/build.dylan b/sources/commands/build.dylan index 0a81e96..5f40521 100644 --- a/sources/commands/build.dylan +++ b/sources/commands/build.dylan @@ -55,7 +55,6 @@ define method execute-subcommand " default libraries configured.")); end; for (name in library-names) - // TODO: this should pass -target dll in some cases. // Let the shell locate dylan-compiler... let command = join(remove(list("dylan-compiler",