Merge pull request #1417 from cgay/file-locator

Add file-locator function, analogous to subdirectory-locator

Author: cgay

documentation/library-reference/source/system/locators.rst

@@ -453,6 +453,25 @@ The locators Module
 
        let build-dir = subdirectory-locator(working-directory(), "_build");
 
+.. generic-function:: file-locator
+   :open:
+
+   Returns a file locator for a file in a subdirectory of the given directory.
+
+   :signature: file-locator (directory, name, #rest more-names) => (file)
+
+   :parameter directory: An instance of :class:`<directory-locator>`.
+   :parameter name: An instance of :drm:`<string>`.
+   :parameter #rest more-names: Instances of :drm:`<string>`.
+   :value file: An instance of :class:`<file-locator>`.
+
+   :example:
+
+     .. code-block:: dylan
+
+       let temp = file-locator(temp-directory(), "my-subdir", "my-test.json");
+       ensure-directories-exist(temp);  // Create "my-subdir" directory.
+
 .. generic-function:: supports-list-locator?
    :open:
 

documentation/release-notes/source/2022.1.rst

@@ -104,6 +104,9 @@ system Library
 
 * A segmentation fault when using ``list-locator`` was fixed (`bug 1372 <https://github.com/dylan-lang/opendylan/issues/1372>`_).
 
+* Function ``file-locator``, to create a file locator as a child of a directory
+  locator, is now exported from the locators module.
+
 c-ffi Library
 -------------
 

sources/system/library.dylan

@@ -142,6 +142,7 @@ define module locators
 
   // Utilities
   create
+    file-locator,
     merge-locators,
     relative-locator,
     resolve-locator,

sources/system/locators/locators.dylan

@@ -17,12 +17,13 @@ define open generic locator-directory
 define open generic locator-relative?
     (locator :: <locator>) => (relative? :: <boolean>);
 
-// For locator /a/b/c.d this will return #("a", "b").
+// For file locator /a/b/c this returns #["a", "b"].
+// For directory locator /a/b/c/ this returns #["a", "b", "c"].
 define open generic locator-path
     (locator :: <locator>) => (path :: <sequence>);
 
-// The locator name, e.g. for locator /a/b/c.d
-// this will return "c.d"
+// For file locator /a/b/c this returns "c".
+// For directory locator /a/b/c/ this returns "c".
 define open generic locator-name
   (locator :: <locator>) => (name :: false-or(<string>));
 
@@ -238,6 +239,31 @@ define method subdirectory-locator
        relative?: locator.locator-relative?)
 end method subdirectory-locator;
 
+
+/// File locator
+
+// Make a <file-locator> that is a child of `directory`. If more than one name
+// is supplied, the last name is the name of the file and earlier names are
+// subdirectories.
+define open generic file-locator
+    (directory :: <directory-locator>, name, #rest more-names)
+ => (file :: <file-locator>);
+
+define method file-locator
+    (directory :: <directory-locator>, name :: <string>, #rest more-names)
+ => (file :: <file-locator>)
+  let length = more-names.size;
+  if (length == 0)
+    make(<file-locator>, directory: directory, name: name)
+  else
+    make(<file-locator>,
+         directory: apply(subdirectory-locator, directory, name,
+                          copy-sequence(more-names, end: length - 1)),
+         name: last(more-names))
+  end
+end method;
+
+
 
 /// Relative locator
 

sources/system/tests/locators.dylan

@@ -443,6 +443,36 @@ define test test-subdirectory-locator ()
      $microsoft-subdirectory-tests)
 end test;
 
+define test test-file-locator ()
+  // file-locator calls make(<file-locator>) which calls
+  // make(<native-file-locator>) passing `dir` (below) as the directory, which
+  // crashes if passed a locator for another platform. That's why this code
+  // doesn't attempt to test both Microsoft locators and POSIX locators on all
+  // platforms and instead branches based on $os-name. This could be fixed if
+  // we want to but I don't think it's a goal of the locators code be able to
+  // use all platform-specific locator types on all platforms, even if it does
+  // work for some of the other locators tests. --cgay
+  let posix-args
+    = #[#["/a/b/", #["c"], "/a/b/c"],
+        #["/a/b/", #["c", "d"], "/a/b/c/d"],
+        #["/a/b/", #["c", "d", "e"], "/a/b/c/d/e"]];
+  let windows-args
+    = #[#["c:\\a\\b\\", #["c"], "c:\\a\\b\\c"],
+        #["c:\\a\\b\\", #["c", "d"], "c:\\a\\b\\c\\d"],
+        #["\\\\a\\b\\", #["c", "d", "e"], "\\\\a\\b\\c\\d\\e"]];
+  for (args in if ($os-name == #"win32")
+                 windows-args
+               else
+                 posix-args
+               end)
+    let dir = as(<directory-locator>, args[0]);
+    let names = args[1];
+    let want = as(<file-locator>, args[2]);
+    check-equal(format-to-string("file-locator(%=, %=) = %=", dir, names, want),
+                want, apply(file-locator, dir, names));
+  end;
+end test;
+
 define constant $relative-tests
   = #[#["a",         "a",         "a"],
       #["a",         "b",         "a"],
@@ -603,6 +633,7 @@ define suite more-locators-test-suite ()
   test test-string-as-locator;
   test test-simplify-locator;
   test test-subdirectory-locator;
+  test test-file-locator;
   test test-relative-locator;
   test test-merge-locators;
   test test-resolve-locator;