Pin a crate in a remote monorepo

src/alire/alire-roots-editable.adb

@@ -373,7 +373,8 @@ package body Alire.Roots.Editable is
                              Crate  : Alire.Optional.Crate_Name;
                              Origin : URL;
                              Ref    : String := "";
-                             Branch : String := "")
+                             Branch : String := "";
+                             Subdir : Relative_Path := "")
    is
 
       ---------------------------
@@ -444,6 +445,9 @@ package body Alire.Roots.Editable is
          package Adirs renames Ada.Directories;
       begin
 
+         --  TODO: Probably need to ensure the subdir exists and there is a
+         --  alire.toml manifest. Where this should go?
+
          --  Put in place the checkout, as it is valid if we reached this point
 
          if not Adirs.Exists (This.Edit.Pins_Dir) then
@@ -464,7 +468,8 @@ package body Alire.Roots.Editable is
                                 Crate,
                                 User_Pins.New_Remote (URL    => Origin,
                                                       Commit => Ref,
-                                                      Branch => Branch));
+                                                      Branch => Branch,
+                                                      Subdir => Subdir));
          This.Reload_Manifest;
 
          --  And update lockfile. We need to call Deploy on the pin (although

src/alire/alire-roots-editable.ads

@@ -99,7 +99,8 @@ package Alire.Roots.Editable is
                              Crate  : Optional.Crate_Name;
                              Origin : URL;
                              Ref    : String := "";
-                             Branch : String := "")
+                             Branch : String := "";
+                             Subdir : Relative_Path := "")
      with Pre =>
        (not (Ref /= "" and then Branch /= "")
         or else raise Checked_Error with

src/alire/alire-user_pins.adb

@@ -16,6 +16,7 @@ package body Alire.User_Pins is
    package Keys is
       Branch   : constant String := "branch";
       Commit   : constant String := "commit";
+      Subdir   : constant String := "subdir";
       Internal : constant String := "lockfiled";
       Path     : constant String := "path";
       URL      : constant String := "url";
@@ -42,14 +43,16 @@ package body Alire.User_Pins is
    -- New_Remote --
    ----------------
 
-   function New_Remote (URL : Alire.URL;
+   function New_Remote (URL    : Alire.URL;
                         Commit : String := "";
-                        Branch : String := "")
+                        Branch : String := "";
+                        Subdir : Alire.Relative_Path := "")
                         return Pin
    is (Kind       => To_Git,
        URL        => +URL,
        Commit     => +Commit,
        Branch     => +Branch,
+       Subdir     => +Subdir,
        Local_Path => <>);
 
    -----------
@@ -90,6 +93,9 @@ package body Alire.User_Pins is
                   then ", branch='" & (+This.Branch) & "'"
                   elsif This.Commit /= ""
                   then ", commit='" & (+This.Commit) & "'"
+                  else "")
+               & (if This.Subdir /= ""
+                  then ", subdir='" & (+This.Subdir) & "'"
                   else ""))
        & " }");
 
@@ -270,8 +276,12 @@ package body Alire.User_Pins is
       --  At this point, we have the sources at Destination. Last checks ensue.
 
       declare
-         Root : Roots.Optional.Root :=
-                  Roots.Optional.Detect_Root (Destination);
+         use Directories.Operators; -- "/"
+
+         Subdir : constant String := +This.Subdir;
+         Root   : Roots.Optional.Root := Roots.Optional.Detect_Root
+           ((if Subdir = "" then Destination
+             else Destination / Subdir));
       begin
 
          --  Check crate name mismatch
@@ -312,6 +322,9 @@ package body Alire.User_Pins is
                               else Origins.Short_Commit (+This.Commit))
          elsif Branch (This).Has_Element
          then "#" & TTY.Emph (+This.Branch)
+         else "")
+       & (if Subdir (This).Has_Element
+         then "#" & TTY.Emph (+This.Subdir)
          else ""));
 
    ----------
@@ -398,6 +411,11 @@ package body Alire.User_Pins is
                      Result.Branch :=
                        +This.Checked_Pop (Keys.Branch, TOML_String).As_String;
                   end if;
+
+                  if This.Contains (Keys.Subdir) then
+                     Result.Subdir :=
+                       +This.Checked_Pop (Keys.Subdir, TOML_String).As_String;
+                  end if;
                end return;
 
             else
@@ -465,6 +483,7 @@ package body Alire.User_Pins is
                           TOML_String).As_String,
                         Branch     => <>,
                         Commit     => <>,
+                        Subdir     => <>,
                         Local_Path => <>);
          begin
             if This.Contains (Keys.Branch)
@@ -488,6 +507,13 @@ package body Alire.User_Pins is
                             "branch cannot be the empty string");
             end if;
 
+            if This.Contains (Keys.Subdir) then
+               Result.Subdir :=
+                 +This.Checked_Pop (Keys.Subdir, TOML_String).As_String;
+               This.Assert (+Result.Subdir /= "",
+                            "subdir cannot be the empty string");
+            end if;
+
             --  TEST: empty branch value
 
             This.Report_Extra_Keys;
@@ -568,6 +594,12 @@ package body Alire.User_Pins is
             Table.Set (Keys.Branch,
                        Create_String (Branch (This).Element.Ptr.all));
          end if;
+
+         --  TODO: Should this use the "VFS.Attempt_Portable"?
+         if Subdir (This).Has_Element then
+            Table.Set (Keys.Subdir,
+                       Create_String (Subdir (This).Element.Ptr.all));
+         end if;
       end if;
 
       Table.Set (Keys.Path,

src/alire/alire-user_pins.ads

@@ -62,9 +62,10 @@ package Alire.User_Pins is
 
    --  Remote pins
 
-   function New_Remote (URL : Alire.URL;
+   function New_Remote (URL    : Alire.URL;
                         Commit : String := "";
-                        Branch : String := "")
+                        Branch : String := "";
+                        Subdir : Alire.Relative_Path := "")
                         return Pin
      with
        Pre => Commit = "" or else VCSs.Git.Is_Valid_Commit (Commit),
@@ -79,6 +80,9 @@ package Alire.User_Pins is
    function Commit (This : Pin) return Optional.String
      with Pre => This.Is_Remote;
 
+   function Subdir (This : Pin) return Optional.String
+     with Pre => This.Is_Remote;
+
    function TTY_URL_With_Reference (This     : Pin;
                                     Detailed : Boolean := False)
                                     return String
@@ -137,6 +141,7 @@ private
             URL        : UString;
             Branch     : UString; -- Optional
             Commit     : UString; -- Optional
+            Subdir     : UString; -- Optional
             Local_Path : Unbounded_Absolute_Path;
             --  Empty until the pin is locally deployed
          when To_Path =>
@@ -164,6 +169,15 @@ private
        then Optional.Strings.Empty
        else Optional.Strings.Unit (+This.Commit));
 
+   ------------
+   -- Subdir --
+   ------------
+
+   function Subdir (This : Pin) return Optional.String
+   is (if +This.Subdir = ""
+       then Optional.Strings.Empty
+       else Optional.Strings.Unit (+This.Subdir));
+
    ---------------
    -- Is_Remote --
    ---------------

src/alr/alr-commands-pin.adb

@@ -190,7 +190,8 @@ package body Alr.Commands.Pin is
                  (Crate  => Optional_Crate,
                   Origin => Cmd.URL.all,
                   Ref    => Cmd.Commit.all,
-                  Branch => Cmd.Branch.all);
+                  Branch => Cmd.Branch.all,
+                  Subdir => Cmd.Subdir.all);
 
             else
 
@@ -257,9 +258,11 @@ package body Alr.Commands.Pin is
                & " instead of looking for indexed releases."
                & " An optional reference can be specified with --commit;"
                & " the pin will be frozen at the commit currently matching"
-               & " the reference.  Alternatively, a branch to track can be"
-               & " specified with --branch. Use `alr update` to refresh the"
-               & " tracking pin contents.")
+               & " the reference. Alternatively, a branch to track can be"
+               & " specified with --branch. Finally, if pinning a monorepo,"
+               & " the relative path to the crate can be specified with"
+               & " --subdir. Use `alr update` to refresh the tracking pin"
+               & " contents.")
      );
 
    --------------------
@@ -297,6 +300,14 @@ package body Alr.Commands.Pin is
          Argument    => "REF",
          Help        => "Reference to be retrieved from repository");
 
+      Define_Switch
+        (Config      => Config,
+         Output      => Cmd.Subdir'Access,
+         Long_Switch => "--subdir=",
+         Argument    => "PATH",
+         Help        =>
+           "Path to the crate relative to the root of the repository");
+
       Define_Switch
         (Config      => Config,
          Output      => Cmd.URL'Access,

src/alr/alr-commands-pin.ads

@@ -30,14 +30,15 @@ package Alr.Commands.Pin is
    overriding
    function Usage_Custom_Parameters (Cmd : Command) return String
    is ("[[crate[=<version>]]"
-       & " | crate --use=<path> [--commit=REF] [--branch=NAME]"
+       & " | crate --use=<path> [--commit=REF] [--branch=NAME] [--subdir=PATH]"
        & " | --all]");
 
 private
 
    type Command is new Commands.Command with record
       Branch  : aliased GNAT.Strings.String_Access;
       Commit  : aliased GNAT.Strings.String_Access;
+      Subdir  : aliased GNAT.Strings.String_Access;
       Pin_All : aliased Boolean;
       Unpin   : aliased Boolean;
       URL     : aliased GNAT.Strings.String_Access;