bug box in case of Program_Error

src/alire/alire-directories.adb

@@ -331,7 +331,7 @@ package body Alire.Directories is
       --  like "/c/alire". This is for peace of mind.
 
       if Path'Length < 8 then
-         Recoverable_Error ("Suspicious deletion request for path: " & Path);
+         Recoverable_User_Error ("Suspicious deletion request for path: " & Path);
       end if;
 
       if Exists (Path) then
@@ -828,7 +828,7 @@ package body Alire.Directories is
 
          if Adirs.Exists (Dst) then
             if Fail_On_Existing_File then
-               Recoverable_Error ("Cannot move " & TTY.URL (Src)
+               Recoverable_User_Error ("Cannot move " & TTY.URL (Src)
                                   & " into place, file already exists: "
                                   & TTY.URL (Dst));
             elsif Adirs.Kind (Dst) /= Ordinary_File then

src/alire/alire-errors.adb

@@ -1,4 +1,9 @@
+with AAA.Debug;
+with AAA.Strings;
+
 with Ada.Containers.Indefinite_Ordered_Maps;
+
+with Alire.OS_Lib;
 with Alire.Utils;
 
 package body Alire.Errors is
@@ -238,4 +243,75 @@ package body Alire.Errors is
       return +Msg & Text;
    end Stack;
 
+   -------------------
+   -- Program_Error --
+   -------------------
+
+   procedure Program_Error (Explanation  : String  := "";
+                            Recoverable  : Boolean := True;
+                            Stack_Trace  : String  := "";
+                            Stack_Offset : Natural := 0)
+   is
+      Stack  : constant AAA.Strings.Vector :=
+                 AAA.Strings.Split
+                   ((if Stack_Trace /= ""
+                    then Stack_Trace
+                    else AAA.Debug.Stack_Trace),
+                    ASCII.LF);
+
+      Caller : constant Positive :=
+                 5 + Stack_Offset - (if Stack_Trace /= "" then 2 else 0);
+      -- The minus 2 is because in stacks obtained from the original exception:
+      -- 1) Except name 2) exec name 3) stack start
+      -- If instead we use AAA.Debug.Stack_Trace:
+      -- 1) Except name 2) exec name 3) AAA.Debug 4) here 5) caller
+
+      URL    : constant String
+      := "https://github.com/alire-project/alire/issues/new?title=[Bug%20box]";
+
+      Level  : constant Trace.Levels :=
+                 (if Recoverable then Warning else Error);
+
+      ---------
+      -- Put --
+      ---------
+
+      procedure Put (Msg : String) is
+      begin
+         Trace.Log (Msg, Level);
+      end Put;
+
+   begin
+      Trace.Debug (AAA.Debug.Stack_Trace);
+
+      Put ("******************* BEGIN Alire bug detected *******************");
+      Put ("Location  : "
+           & (if integer (Stack.Length) >= Caller
+             then Stack (Caller)
+             else "<unknown>"));
+
+      if Explanation /= "" then
+         Put ("Extra info: " & Explanation);
+      end if;
+
+      Put ("Report at : " & URL);
+
+      if Log_Level < Debug or else not Log_Debug then
+         Put ("Re-run with `-vv -d` for a full stack trace.");
+      end if;
+
+      if Recoverable then
+         Put
+           (TTY.Bold
+              ("Alire will now continue as the error might be recoverable."));
+      end if;
+
+      Put ("******************** END Alire bug detected ********************");
+
+      if not Recoverable then
+         --  Do not re-raise as we would end repeating the -vv -d info
+         OS_Lib.Bailout (1);
+      end if;
+   end Program_Error;
+
 end Alire.Errors;

src/alire/alire-errors.ads

@@ -122,6 +122,21 @@ package Alire.Errors with Preelaborate is
    function Stack (Text : String) return String;
    --  Return current error stack, plus Text as the latest error
 
+   -----------
+   -- Other --
+   -----------
+
+   procedure Program_Error (Explanation  : String  := "";
+                            Recoverable  : Boolean := True;
+                            Stack_Trace  : String  := "";
+                            Stack_Offset : Natural := 0);
+   --  For unexpected situations where normally a Program_Error would be
+   --  adecuate, but we do not want to bomb on the user because continuing is
+   --  acceptable. We log a stack trace, print a warning and continue, so a
+   --  motivated user can report an issue, but we don't needlessly raise. If
+   --  not Survivable, then do raise a Program_Error. If Stack_Trace /= "",
+   --  use it instead of generating one.
+
 private
 
    Id_Marker : constant String := "alire-stored-error:";

src/alire/alire-install.adb

@@ -327,7 +327,7 @@ package body Alire.Install is
 
                --  A different version exists, here we fail unless forced
 
-               Recoverable_Error
+               Recoverable_User_Error
                  (Errors.New_Wrapper
                     ("Release " & Rel.Milestone.TTY_Image
                      & " has another version already installed: ")

src/alire/alire-publish.adb

@@ -244,7 +244,7 @@ package body Alire.Publish is
 
       Index_On_Disk.Loading.Load_All (Strict => True).Assert;
       if Index.Exists (Release.Name, Release.Version) then
-         Recoverable_Error
+         Recoverable_User_Error
             ("Target release " & Release.Milestone.TTY_Image
              & " already exist in a loaded index");
       end if;
@@ -564,7 +564,7 @@ package body Alire.Publish is
             if OS_Lib.Getenv (Environment.Testsuite, "unset") /= "unset"
               and then OS_Lib.Getenv (Environment.Testsuite_Allow, "unset") = "unset"
             then
-               raise Program_Error
+               raise Constraint_Error
                  with "Attempting to go online to create a PR during tests";
             end if;
 
@@ -827,7 +827,7 @@ package body Alire.Publish is
          --  User must exist
 
          if not GitHub.User_Exists (Login) then
-            Recoverable_Error
+            Recoverable_User_Error
               ("Your GitHub login does not seem to exist: "
                & TTY.Emph (Login));
          end if;
@@ -838,7 +838,7 @@ package body Alire.Publish is
             Put_Success ("User has forked the community repository");
          else
             if not Submit.Ask_To_Fork (Context) then
-               Recoverable_Error
+               Recoverable_User_Error
                  ("You must fork the community index to your GitHub account"
                & ASCII.LF & "Please visit "
                & TTY.URL (Tail (Index.Community_Repo, '+'))
@@ -868,7 +868,7 @@ package body Alire.Publish is
 
          --  Otherwise we assume this is a local path
 
-         Recoverable_Error
+         Recoverable_User_Error
            ("The origin must be a definitive remote location, but is " & URL);
          --  For testing we may want to allow local URLs, or may be for
          --  internal use with network drives? So allow forcing it.

src/alire/alire-releases.adb

@@ -201,8 +201,8 @@ package body Alire.Releases is
            & (case R.Origin.Kind is
                  when Git | Hg => R.Origin.Short_Unique_Id,
                  when SVN => R.Origin.Commit,
-                 when others => raise Program_Error
-                   with "monorepo folder only applies to VCS origins");
+                 when others => raise Program_Error with
+                   "monorepo folder only applies to VCS origins");
       end Monorepo_Path;
 
       ------------------

src/alire/alire-roots-editable.adb

@@ -135,7 +135,7 @@ package body Alire.Roots.Editable is
         and then not Index.Exists (Dep.Crate)
         and then Index.Releases_For_Crate (Dep.Crate).Is_Empty
       then
-         Alire.Recoverable_Error
+         Alire.Recoverable_User_Error
            ("Cannot add crate '" & Alire.Utils.TTY.Name (Dep.Crate)
             & "' not found in index.");
       end if;

src/alire/alire-roots.adb

@@ -21,6 +21,7 @@ with Alire.Utils.TTY;
 with Alire.Utils.User_Input;
 
 with GNAT.OS_Lib;
+with GNAT.SHA256;
 
 with Semantic_Versioning.Extended;
 
@@ -317,7 +318,10 @@ package body Alire.Roots is
            ("Requested build hash of release " & Name.As_String
             & " not among solution states:");
          This.Solution.Print_States ("   ", Error);
-         raise Program_Error;
+         Recoverable_Program_Error ("using default hash");
+         --  Using an improperly computed hash may cause some unexpected
+         --  recompilations but should be less of a show-stopper.
+         return "error:" & GNAT.SHA256.Digest (Name.As_String);
       end if;
    end Build_Hash;
 
@@ -1516,7 +1520,8 @@ package body Alire.Roots is
       elsif This.Solution.State (Crate).Is_Linked then
          return This.Solution.State (Crate).Link.Path;
       else
-         raise Program_Error with "release must be either solved or linked";
+         raise Program_Error with
+           "release must be either solved or linked";
       end if;
    end Release_Base;
 
@@ -1887,7 +1892,7 @@ package body Alire.Roots is
          if Old.Pins.Contains (Crate) then
             --  The solver will never update a pinned crate, so we may allow
             --  this to be attempted but it will have no effect.
-            Recoverable_Error
+            Recoverable_User_Error
               ("Requested crate is pinned and cannot be updated: "
                & Alire.Utils.TTY.Name (Crate));
          end if;

src/alire/alire-solutions-diffs.adb

@@ -303,7 +303,8 @@ package body Alire.Solutions.Diffs is
             --  disappearing from the solutions.
             Chg.Best_Version := +Best_Version (Former);
          else
-            raise Program_Error with "crate is neither in former or latter";
+            Recoverable_Program_Error
+              ("crate is neither in former or latter");
          end if;
 
       end Determine_Relevant_Version;
@@ -335,11 +336,10 @@ package body Alire.Solutions.Diffs is
             if Rel.Origin.Kind in Report_Kinds then
                Add_Change (Chg, Icon (Binary),
                            TTY.Warn
-                             (case Rel.Origin.Kind is
+                             (case Report_Kinds (Rel.Origin.Kind) is
                                  when Binary_Archive => "binary",
                                  when External       => "executable in path",
-                                 when System         => "system package",
-                                 when others         => raise Program_Error));
+                                 when System         => "system package"));
             end if;
          end;
       end Releases_Without_Sources;

src/alire/alire-solutions.adb

@@ -788,7 +788,7 @@ package body Alire.Solutions is
                   & TTY.Emph (" (pinned)"),
                   Level);
             else
-               Report_Program_Error;
+               Recoverable_Program_Error;
                --  This should be unreachable, as dependencies in this block
                --  should either have a release or a link.
             end if; -- has release
@@ -1276,7 +1276,7 @@ package body Alire.Solutions is
       end loop;
 
       raise Program_Error with Errors.Set
-        ("No dependency in solution matches release "
+         ("No dependency in solution matches release "
          & Release.Milestone.TTY_Image);
    end State;
 
@@ -1540,8 +1540,8 @@ package body Alire.Solutions is
             --  that were marked as safe to visit in the 1st step of the round.
 
             if To_Remove.Is_Empty then
-               raise Program_Error
-                 with "No release visited in round" & Round'Img;
+               raise Program_Error with
+                 "No release visited in round" & Round'Img;
             else
                for Dep of To_Remove loop
                   Visit (Dep);

src/alire/alire-toml_adapters.adb

@@ -68,7 +68,7 @@ package body Alire.TOML_Adapters is
    is
    begin
       if Recover then
-         Recoverable_Error (Message, Recover);
+         Recoverable_User_Error (Message, Recover);
       else
          Queue.Checked_Error (Message);
       end if;
@@ -86,7 +86,8 @@ package body Alire.TOML_Adapters is
       Queue.Assert_Key (Key, Kind);
       return Value : TOML.TOML_Value do
          if not Queue.Pop (Key, Value) then
-            raise Program_Error with ("missing key, but it was just checked?");
+            raise Program_Error with
+              "missing key, but it was just checked?";
          end if;
       end return;
    end Checked_Pop;
@@ -327,7 +328,7 @@ package body Alire.TOML_Adapters is
 
       if Errored then
          if Force then
-            Recoverable_Error (+Message);
+            Recoverable_User_Error (+Message);
             return Outcome_Success;
          else
             return Outcome_Failure (+Message);

src/alire/alire-toolchains.adb

@@ -683,7 +683,7 @@ package body Alire.Toolchains is
       end if;
 
       if Toolchains.Solutions.Is_In_Toolchain (Release) then
-         Recoverable_Error ("The release to be removed ("
+         Recoverable_User_Error ("The release to be removed ("
                             & Release.Milestone.TTY_Image & ") is part of the "
                             & "configured default toolchain.");
 

src/alire/alire-utils-user_input.adb

@@ -79,7 +79,7 @@ package body Alire.Utils.User_Input is
       if not Check_Absolute_Path (User_Path) and then
         not VFS.Is_Portable (User_Path)
       then
-         Recoverable_Error
+         Recoverable_User_Error
            (Error_When_Relative_Native & ": " & TTY.URL (User_Path));
       end if;
 

src/alire/alire.adb

@@ -276,12 +276,12 @@ package body Alire is
    -- Recoverable_Error --
    -----------------------
 
-   procedure Recoverable_Error (Msg : String; Recover : Boolean := Force) is
+   procedure Recoverable_User_Error (Msg : String; Recover : Boolean := Force) is
       Info : constant String := " (This error can be overridden with "
                                 & TTY.Terminal ("--force") & ".)";
    begin
       if Msg'Length > 0 and then Msg (Msg'Last) /= '.' then
-         Recoverable_Error (Msg & ".", Recover);
+         Recoverable_User_Error (Msg & ".", Recover);
          return;
       end if;
 
@@ -290,7 +290,19 @@ package body Alire is
       else
          Raise_Checked_Error (Msg & Info);
       end if;
-   end Recoverable_Error;
+   end Recoverable_User_Error;
+
+   -------------------------------
+   -- Recoverable_Program_Error --
+   -------------------------------
+
+   procedure Recoverable_Program_Error (Explanation : String := "") is
+   begin
+      Errors.Program_Error (Explanation,
+                            Recoverable  => True,
+                            Stack_Offset => 1);
+      --  Offset is 1 because this procedure adds its own stack frame
+   end Recoverable_Program_Error;
 
    --------------
    -- New_Line --