From 1000e5cf3a639c0bdb96e210ad1b8f85400c18ec Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Tue, 18 Aug 2020 11:00:41 +0200 Subject: [PATCH] New Alire.Roots.Optional type (#492) In most cases, the Root has to be valid so it can be used. This patch moves the Is_Valid code smell to a separate child type (Alire.Roots.Optional.Root) that can be used in the few cases where all the root states have to be treated separately. This obsoletes Alr.Bootstrap.Session_States too. --- src/alire/alire-config.adb | 3 +- src/alire/alire-config.ads | 2 +- src/alire/alire-dependencies-states.adb | 11 +- src/alire/alire-directories.adb | 4 + src/alire/alire-outcomes-definite.ads | 9 +- src/alire/alire-outcomes-indefinite.ads | 10 +- src/alire/alire-releases.adb | 15 ++- src/alire/alire-root.adb | 42 ++------ src/alire/alire-root.ads | 7 +- src/alire/alire-roots-check_valid.adb | 23 ----- src/alire/alire-roots-check_valid.ads | 4 - src/alire/alire-roots-optional.adb | 128 ++++++++++++++++++++++++ src/alire/alire-roots-optional.ads | 72 +++++++++++++ src/alire/alire-roots.adb | 117 ++++++++-------------- src/alire/alire-roots.ads | 98 ++++++------------ src/alire/alire-workspace.ads | 3 +- src/alire/alire.adb | 22 ++-- src/alire/alire.ads | 9 +- src/alr/alr-bootstrap.adb | 20 +--- src/alr/alr-bootstrap.ads | 29 +----- src/alr/alr-commands-clean.adb | 23 ++--- src/alr/alr-commands-get.adb | 6 +- src/alr/alr-commands-init.adb | 39 +++++--- src/alr/alr-commands-show.adb | 18 ++-- src/alr/alr-commands-version.adb | 26 +++-- src/alr/alr-commands-withing.adb | 6 +- src/alr/alr-commands.adb | 95 ++++++++++-------- src/alr/alr-commands.ads | 6 -- src/alr/alr-root.adb | 14 --- src/alr/alr-root.ads | 9 +- 30 files changed, 466 insertions(+), 404 deletions(-) delete mode 100644 src/alire/alire-roots-check_valid.adb delete mode 100644 src/alire/alire-roots-check_valid.ads create mode 100644 src/alire/alire-roots-optional.adb create mode 100644 src/alire/alire-roots-optional.ads delete mode 100644 src/alr/alr-root.adb diff --git a/src/alire/alire-config.adb b/src/alire/alire-config.adb index 7f20cbc8..69e1cb15 100644 --- a/src/alire/alire-config.adb +++ b/src/alire/alire-config.adb @@ -4,9 +4,9 @@ with Ada.Text_IO; with GNAT.Regexp; +with Alire.Directories; with Alire.Environment; with Alire.Platform; -with Alire.Directories; with TOML.File_IO; @@ -360,7 +360,6 @@ package body Alire.Config is for Lvl in Level loop if Lvl /= Local or else Root.Current.Is_Valid then - declare Config : constant TOML_Value := Load_Config_File (Filepath (Lvl)); diff --git a/src/alire/alire-config.ads b/src/alire/alire-config.ads index d05a38aa..0273e24e 100644 --- a/src/alire/alire-config.ads +++ b/src/alire/alire-config.ads @@ -1,6 +1,6 @@ with Alire.OS_Lib; use Alire.OS_Lib.Operators; -with Alire.Utils; with Alire.Root; +with Alire.Utils; with TOML; diff --git a/src/alire/alire-dependencies-states.adb b/src/alire/alire-dependencies-states.adb index 67e97921..10b88c7d 100644 --- a/src/alire/alire-dependencies-states.adb +++ b/src/alire/alire-dependencies-states.adb @@ -1,6 +1,6 @@ with Alire.Crates; with Alire.Manifest; -with Alire.Roots; +with Alire.Roots.Optional; package body Alire.Dependencies.States is @@ -12,16 +12,17 @@ package body Alire.Dependencies.States is Workspace : Any_Path) return Containers.Release_H is - Opt_Root : constant Roots.Root := Roots.Detect_Root (Workspace); + Opt_Root : constant Roots.Optional.Root := + Roots.Optional.Detect_Root (Workspace); begin if Opt_Root.Is_Valid then - if Opt_Root.Release.Name = Crate then - return Containers.To_Release_H (Opt_Root.Release); + if Opt_Root.Value.Release.Name = Crate then + return Containers.To_Release_H (Opt_Root.Value.Release); else Raise_Checked_Error ("crate mismatch: expected " & Crate.TTY_Image & " but found " - & Opt_Root.Release.Name.TTY_Image + & Opt_Root.Value.Release.Name.TTY_Image & " at " & TTY.URL (Workspace)); end if; else diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 78120a4f..01070bc0 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -184,6 +184,10 @@ package body Alire.Directories is End_Search (Search); return ""; end if; + exception + when Name_Error => + Trace.Debug ("Search path does not exist: " & Path); + return ""; end Find_Single_File; ---------------- diff --git a/src/alire/alire-outcomes-definite.ads b/src/alire/alire-outcomes-definite.ads index a2329d21..41b91ce7 100644 --- a/src/alire/alire-outcomes-definite.ads +++ b/src/alire/alire-outcomes-definite.ads @@ -20,7 +20,9 @@ package Alire.Outcomes.Definite with Preelaborate is raise Checked_Error with Errors.Set (This.Message); overriding - function Outcome_Failure (Message : String) return Outcome; + function Outcome_Failure (Message : String; + Report : Boolean := True) + return Outcome; overriding function Outcome_Success return Outcome is @@ -52,8 +54,9 @@ private (Ptr => This.The_Result'Access); overriding - function Outcome_Failure (Message : String) return Outcome is - (Alire.Outcome_Failure (Message) with OK => False); + function Outcome_Failure (Message : String; + Report : Boolean := True) return Outcome + is (Alire.Outcome_Failure (Message, Report) with OK => False); overriding function Outcome_From_Exception diff --git a/src/alire/alire-outcomes-indefinite.ads b/src/alire/alire-outcomes-indefinite.ads index c653f713..eda15b1d 100644 --- a/src/alire/alire-outcomes-indefinite.ads +++ b/src/alire/alire-outcomes-indefinite.ads @@ -22,7 +22,9 @@ package Alire.Outcomes.Indefinite with Preelaborate is raise Checked_Error with Errors.Set (This.Message); overriding - function Outcome_Failure (Message : String) return Outcome; + function Outcome_Failure (Message : String; + Report : Boolean := True) + return Outcome; overriding function Outcome_Success return Outcome is @@ -68,8 +70,10 @@ private (This.The_Result.First).Element); overriding - function Outcome_Failure (Message : String) return Outcome is - (Alire.Outcome_Failure (Message) with OK => False); + function Outcome_Failure (Message : String; + Report : Boolean := True) + return Outcome + is (Alire.Outcome_Failure (Message, Report) with OK => False); overriding function Outcome_From_Exception diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index 496c5051..db3df05b 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -576,11 +576,18 @@ package body Alire.Releases is Source : Manifest.Sources) return Release is - (From_TOML + begin + return From_TOML (TOML_Adapters.From - (TOML_Load.Load_File (File_Name), - "Loading release from manifest: " & File_Name), - Source)); + (TOML_Load.Load_File (File_Name), + "Loading release from manifest: " & File_Name), + Source); + exception + when E : others => + -- As this file is edited manually, it may not load for many reasons + Raise_Checked_Error (Errors.Wrap ("Failed to load " & File_Name, + Errors.Get (E))); + end From_Manifest; --------------- -- From_TOML -- diff --git a/src/alire/alire-root.adb b/src/alire/alire-root.adb index 0334ca47..713aa690 100644 --- a/src/alire/alire-root.adb +++ b/src/alire/alire-root.adb @@ -1,7 +1,4 @@ with Alire.Directories; -with Alire.Errors; -with Alire.Manifest; -with Alire.Paths; with Alire.Releases; package body Alire.Root is @@ -10,36 +7,15 @@ package body Alire.Root is -- Current -- ------------- - function Current return Roots.Root is - use Alire.Directories; - Path : constant String := Directories.Detect_Root_Path; - begin - if Path /= "" then - declare - File : constant String := - Directories.Find_Single_File - (Path => Path / Paths.Working_Folder_Inside_Root, - Extension => Paths.Crate_File_Extension_With_Dot); - begin - return Roots.New_Root - (Releases.From_Manifest (File, Manifest.Local), - Path, - Platform_Properties); - exception - when E : others => - Trace.Debug ("Exception while loading crate file is:"); - Log_Exception (E, Debug); - - return Roots.New_Invalid_Root.With_Reason - (Errors.Wrap ("Failed to load " & File, - Errors.Get (E))); - end; - else - return Roots.New_Invalid_Root.With_Reason - ("Could not detect a session folder" & - " at current or parent locations"); - end if; - end Current; + function Current return Roots.Optional.Root + is (Roots.Optional.Detect_Root (Directories.Detect_Root_Path)); + + ------------- + -- Current -- + ------------- + + function Current return Roots.Root + is (Roots.Optional.Detect_Root (Directories.Detect_Root_Path).Value); Environment : Properties.Vector; diff --git a/src/alire/alire-root.ads b/src/alire/alire-root.ads index 4428c13a..12a67e00 100644 --- a/src/alire/alire-root.ads +++ b/src/alire/alire-root.ads @@ -1,9 +1,14 @@ with Alire.Properties; -with Alire.Roots; +with Alire.Roots.Optional; package Alire.Root is function Current return Roots.Root; + -- Returns the current root, that must exist, or raises Checked_Error + + function Current return Roots.Optional.Root; + -- Returns an optional root, that may be empty if none detected, or broken + -- if the manifest is not loadable. -- TODO -- This global is a remain of when self-compilation existed diff --git a/src/alire/alire-roots-check_valid.adb b/src/alire/alire-roots-check_valid.adb deleted file mode 100644 index eb72c40d..00000000 --- a/src/alire/alire-roots-check_valid.adb +++ /dev/null @@ -1,23 +0,0 @@ -with Ada.Directories; - -function Alire.Roots.Check_Valid (This : Root) return Root is - use Ada.Directories; -begin - if not This.Is_Valid then - return This; -- Keep as is - elsif not Exists (This.Working_Folder) then - return New_Invalid_Root.With_Reason ("alire subfolder not found"); - elsif Kind (This.Working_Folder) /= Directory then - return New_Invalid_Root.With_Reason - ("Expected alire folder but found a: " & - Kind (This.Working_Folder)'Img); - elsif not Exists (This.Crate_File) then - return New_Invalid_Root.With_Reason - ("Dependency file not found in alire folder"); - elsif Kind (This.Crate_File) /= Ordinary_File then - return New_Invalid_Root.With_Reason - ("Expected ordinary file but found a: " & Kind (This.Crate_File)'Img); - else - return This; -- Nothing untoward detected - end if; -end Alire.Roots.Check_Valid; diff --git a/src/alire/alire-roots-check_valid.ads b/src/alire/alire-roots-check_valid.ads deleted file mode 100644 index 041689ea..00000000 --- a/src/alire/alire-roots-check_valid.ads +++ /dev/null @@ -1,4 +0,0 @@ -function Alire.Roots.Check_Valid (This : Root) return Root - with Post => Check_Valid'Result.Is_Valid or else - Check_Valid'Result.Invalid_Reason /= ""; - -- Check that given Root information is valid (paths, etc) diff --git a/src/alire/alire-roots-optional.adb b/src/alire/alire-roots-optional.adb new file mode 100644 index 00000000..9d90eaad --- /dev/null +++ b/src/alire/alire-roots-optional.adb @@ -0,0 +1,128 @@ +with Ada.Directories; + +with Alire.Directories; +with Alire.Errors; +with Alire.Manifest; +with Alire.Paths; +with Alire.Root; + +package body Alire.Roots.Optional is + + Root_Not_Detected : constant Root := + (Alire.Outcome_Failure + ("Could not detect a session folder" + & " at current or parent locations", + Report => False) with + Status => Outside); + + ----------------- + -- Detect_Root -- + ----------------- + + function Detect_Root (Path : Any_Path) return Optional.Root is + use Directories.Operators; + begin + if Path /= "" then + declare + Crate_File : constant String := Directories.Find_Single_File + (Path => Path / Alire.Paths.Working_Folder_Inside_Root, + Extension => ".toml"); + begin + if Crate_File /= "" then + begin + return This : constant Root := + Outcome_Success + (Roots.New_Root + (R => Releases.From_Manifest (Crate_File, + Manifest.Local), + Path => Ada.Directories.Full_Name (Path), + Env => Alire.Root.Platform_Properties)) + do + -- Crate loaded properly, we can return a valid root here + Trace.Debug ("Valid root found at " & Path); + end return; + exception + when E : others => + return Outcome_Failure + (Errors.Get (E), + Broken, + Report => False); + end; + else + return Root_Not_Detected; + end if; + end; + else + return Root_Not_Detected; + -- This happens when detection of session folders in parent folders + -- has been already attempted by the caller, so it ends calling here + -- with an empty path. + end if; + end Detect_Root; + + --------------- + -- Is_Broken -- + --------------- + + function Is_Broken (This : Root) return Boolean + is (This.Status = Broken); + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (This : Root) return Boolean + is (This.Status = Valid); + + ------------- + -- Outside -- + ------------- + + function Outside (This : Root) return Boolean + is (This.Status = Outside); + + ------------ + -- Status -- + ------------ + + function Status (This : Root) return States + is (This.Status); + + ----------- + -- Value -- + ----------- + + function Value (This : aliased Root) return Reference + is + begin + This.Assert; + return Reference'(Ptr => This.Value'Access); + end Value; + + --------------------- + -- Outcome_Failure -- + --------------------- + + function Outcome_Failure (Message : String; + Status : States; + Report : Boolean) + return Root + is (if Status = Outside then + (Alire.Outcome_Failure (Message, Report) + with Status => Outside) + elsif Status = Broken then + (Alire.Outcome_Failure (Message, Report) + with Status => Broken) + else + raise Program_Error with "precondition not fulfilled"); + + --------------------- + -- Outcome_Success -- + --------------------- + + function Outcome_Success (This : Roots.Root) return Optional.Root + is (Alire.Outcome_Success with + Status => Valid, + Value => This); + +end Alire.Roots.Optional; diff --git a/src/alire/alire-roots-optional.ads b/src/alire/alire-roots-optional.ads new file mode 100644 index 00000000..b0bb8126 --- /dev/null +++ b/src/alire/alire-roots-optional.ads @@ -0,0 +1,72 @@ +package Alire.Roots.Optional is + + type States is + (Outside, + -- There is no alire metadata at all + + Broken, + -- There is metadata that cannot be loaded, root is unusable + + Valid + -- There is loadable metadata and the root is usable + ); + + -- Hit a GNAT bug trying to use Outcomes.Indefinite... using custom impl + + type Root (<>) is new Outcome with private; + + type Reference (Ptr : not null access constant Roots.Root) + is limited null record with + Implicit_Dereference => Ptr; + + function Detect_Root (Path : Any_Path) return Optional.Root; + + function Status (This : Root) return States; + + function Is_Broken (This : Root) return Boolean; + + function Is_Valid (This : Root) return Boolean; + + function Outside (This : Root) return Boolean; + -- True when there is no root at all, broken or valid + + function Value (This : aliased Root) return Reference with + Pre => This.Is_Valid; + + function Outcome_Failure (Message : String; + Status : States; + Report : Boolean) + return Root + with Pre => Status in Outside | Broken; + + function Outcome_Success (This : Roots.Root) return Optional.Root; + +private + + type Root (Status : States) is new Outcome with record + case Status is + when Valid => + Value : aliased Roots.Root; + when others => + null; + end case; + end record; + + overriding + function Outcome_Failure (Unused_Message : String; + Unused_Report : Boolean := True) + return Root + is (raise Program_Error with "Status must be provided"); + + overriding + function Outcome_Success return Root + is (raise Program_Error with + "A successful non-trivial outcome requires a result"); + + overriding + function Outcome_From_Exception + (Unused_Ex : Ada.Exceptions.Exception_Occurrence; + Unused_Msg : String := "") return Root + is (raise Program_Error with "Status must be provided"); + +end Alire.Roots.Optional; diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index a8cd7b6a..a2bd772a 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -1,13 +1,12 @@ with Ada.Calendar; with Ada.Directories; -with Alire.Directories; with Alire.Environment; with Alire.Lockfiles; with Alire.Manifest; with Alire.OS_Lib; with Alire.Paths; -with Alire.Root; +with Alire.Roots.Optional; with Alire.Workspace; with GNAT.OS_Lib; @@ -25,49 +24,51 @@ package body Alire.Roots is end return; end Build_Context; - ----------------- - -- Detect_Root -- - ----------------- + ------------------ + -- Check_Stored -- + ------------------ - function Detect_Root (Path : Any_Path) return Root is - use Alire.OS_Lib; - use GNAT.OS_Lib; - Alire_Path : constant Any_Path := - Path / Alire.Paths.Working_Folder_Inside_Root; + procedure Check_Stored (This : Root) is + Info : constant String := This.Storage_Error; begin - if not Is_Directory (Alire_Path) then - Trace.Debug ("No alire folder while detecting root at " & Path); - return New_Invalid_Root.With_Reason ("No alire metadata directory"); + if Info /= "" then + Raise_Checked_Error (Info); end if; + end Check_Stored; - declare - Crate_File : constant String := Directories.Find_Single_File - (Path => Alire_Path, - Extension => ".toml"); - begin - if Crate_File /= "" then - declare - Release : constant Releases.Release := - Releases.From_Manifest (Crate_File, Manifest.Local); - begin - -- Crate loaded properly, we can return a valid root here - Trace.Debug ("Valid root found at " & Path); - return New_Root (R => Release, - Path => Ada.Directories.Full_Name (Path), - Env => Alire.Root.Platform_Properties); - end; - else - Trace.Debug ("No crate file found at " & Alire_Path); - return New_Invalid_Root.With_Reason ("no crate file found"); - end if; - exception - when E : others => - Trace.Debug ("Crate detection failed while loading toml file:"); - Log_Exception (E); - return New_Invalid_Root.With_Reason - ("toml file found but not loadable: " & Crate_File); - end; - end Detect_Root; + --------------- + -- Is_Stored -- + --------------- + + function Storage_Error (This : Root) return String is + use Ada.Directories; + begin + if not Exists (This.Working_Folder) then + return "alire subfolder not found"; + elsif Kind (This.Working_Folder) /= Directory then + return + "Expected alire folder but found a: " & + Kind (This.Working_Folder)'Img; + elsif not Exists (This.Crate_File) then + return "Manifest file not found in alire folder"; + elsif Kind (This.Crate_File) /= Ordinary_File then + return + "Expected ordinary manifest file but found a: " + & Kind (This.Crate_File)'Img; + elsif not Alire.Manifest.Is_Valid (This.Crate_File, Alire.Manifest.Local) + then + return "Manifest is not loadable: " & This.Crate_File; + else + return ""; + end if; + end Storage_Error; + + --------------- + -- Load_Root -- + --------------- + + function Load_Root (Path : Any_Path) return Root + is (Roots.Optional.Detect_Root (Path).Value); ------------------------------ -- Export_Build_Environment -- @@ -173,34 +174,6 @@ package body Alire.Roots is function Environment (This : Root) return Properties.Vector is (This.Environment); - -------------- - -- Is_Valid -- - -------------- - - function Is_Valid (This : Root) return Boolean is (This.Valid); - - ---------------------- - -- New_Invalid_Root -- - ---------------------- - - function New_Invalid_Root return Root is - (Valid => False, Reason => +""); - - ----------------- - -- With_Reason -- - ----------------- - - function With_Reason (This : Root; Reason : String) return Root is - (Valid => False, - Reason => +Reason); - - -------------------- - -- Invalid_Reason -- - -------------------- - - function Invalid_Reason (This : Root) return String is - (+This.Reason); - -------------- -- New_Root -- -------------- @@ -208,8 +181,7 @@ package body Alire.Roots is function New_Root (Name : Crate_Name; Path : Absolute_Path; Env : Properties.Vector) return Root is - (True, - Env, + (Env, +Path, Containers.To_Release_H (Releases.New_Working_Release (Name))); @@ -220,8 +192,7 @@ package body Alire.Roots is function New_Root (R : Releases.Release; Path : Absolute_Path; Env : Properties.Vector) return Root is - (True, - Env, + (Env, +Path, Containers.To_Release_H (R)); diff --git a/src/alire/alire-roots.ads b/src/alire/alire-roots.ads index 3ae393ee..67cf81b4 100644 --- a/src/alire/alire-roots.ads +++ b/src/alire/alire-roots.ads @@ -9,47 +9,20 @@ with Alire.Utils; package Alire.Roots is -- Type used to encapsulate the information about the working context. - -- Currently, this can either be: - -- - Nothing, when we are outside of a valid alire folder - -- - A release, when we are inside a descendent folder of a valid alire - -- working dir -- A valid alire working dir is one containing an alire/crate.toml file. type Root (<>) is tagged private; - function Is_Valid (This : Root) return Boolean; - - ------------------- - -- Invalid roots -- - ------------------- - - function New_Invalid_Root return Root with - Post => not New_Invalid_Root'Result.Is_Valid; - - function With_Reason (This : Root; Reason : String) return Root with - Pre => not This.Is_Valid, - Post => not This.Is_Valid - and then - With_Reason'Result.Invalid_Reason = Reason; - - function Invalid_Reason (This : Root) return String with - Pre => not This.Is_Valid; - - ----------------- - -- Valid roots -- - ----------------- - - function Detect_Root (Path : Any_Path) return Root; + function Load_Root (Path : Any_Path) return Root; -- Attempt to detect a root at the given path. The root will be valid if -- path/alire exists, path/alire/*.toml is unique and loadable as a crate - -- containing a single release. + -- containing a single release. Otherwise, Checked_Error. -- See Alire.Directories.Detect_Root_Path to use with the following function New_Root (Name : Crate_Name; Path : Absolute_Path; - Env : Properties.Vector) return Root with - Post => New_Root'Result.Is_Valid; + Env : Properties.Vector) return Root; -- New unreleased release (not indexed, working copy) function New_Root (R : Releases.Release; @@ -58,53 +31,55 @@ package Alire.Roots is -- From existing release -- Path must point to the session folder (parent of alire metadata folder) - function Environment (This : Root) return Properties.Vector with - Pre => This.Is_Valid; + procedure Check_Stored (This : Root); + -- Check that the Root information exists on disk (paths exist, + -- files are at expected places...); otherwise Checked_Error + + function Storage_Error (This : Root) return String; + -- Returns the error that Check_Stored_Metadata would raise or "" otherwise + + function Is_Stored (This : Root) return Boolean + is (This.Storage_Error = ""); + -- Check that a root is properly stored + + function Environment (This : Root) return Properties.Vector; -- Retrieve the environment stored within this root. Environment here -- refers to the platform properties. function Build_Context (This : Root) return Alire.Environment.Context; - procedure Export_Build_Environment (This : Root) with - Pre => This.Is_Valid; + procedure Export_Build_Environment (This : Root); -- Export the build environment (PATH, GPR_PROJECT_PATH) of the given root - function Path (This : Root) return Absolute_Path with - Pre => This.Is_Valid; + function Path (This : Root) return Absolute_Path; function Project_Paths (This : Root) - return Utils.String_Set with - Pre => This.Is_Valid; + return Utils.String_Set; -- Return all the paths that should be set in GPR_PROJECT_PATH for the -- solution in this root. This includes al releases' paths and any linked -- directories. function GPR_Project_Files (This : Root; Exclude_Root : Boolean) - return Utils.String_Set with - Pre => This.Is_Valid; + return Utils.String_Set; -- Return all the gprbuild project files defined for the solution in this -- root. If Exclude_Root is True, the project files of the root crate are -- excluded from the result. - function Release (This : Root) return Releases.Release with - Pre => This.Is_Valid; + function Release (This : Root) return Releases.Release; function Release (This : Root; Crate : Crate_Name) return Releases.Release - with Pre => This.Is_Valid and then + with Pre => (Crate = This.Release.Name or else This.Solution.Depends_On (Crate)); -- Retrieve a release, that can be either the root or any in the solution - function Release_Base (This : Root; Crate : Crate_Name) return Any_Path with - Pre => This.Is_Valid; + function Release_Base (This : Root; Crate : Crate_Name) return Any_Path; -- Find the base folder in which a release can be found for the given root - function Solution (This : Root) return Solutions.Solution with - Pre => This.Is_Valid; + function Solution (This : Root) return Solutions.Solution; -- Returns the solution stored in the lockfile - procedure Sync_Solution_And_Deps (This : Root) with - Pre => This.Is_Valid; + procedure Sync_Solution_And_Deps (This : Root); -- Ensure that dependencies are up to date in regard to the lockfile and -- manifest: if the manifest is newer than the lockfile, resolve again, -- as dependencies may have been edited by hand. Otherwise, ensure that @@ -113,33 +88,24 @@ package Alire.Roots is -- files and folders derived from the root path (this obsoletes Alr.Paths) - function Working_Folder (This : Root) return Absolute_Path with - Pre => This.Is_Valid; + function Working_Folder (This : Root) return Absolute_Path; -- The "alire" folder inside the root path - function Crate_File (This : Root) return Absolute_Path with - Pre => This.Is_Valid; + function Crate_File (This : Root) return Absolute_Path; -- The "$crate.toml" file inside Working_Folder - function Dependencies_Dir (This : Root) return Absolute_Path with - Pre => This.Is_Valid; + function Dependencies_Dir (This : Root) return Absolute_Path; -- The folder where dependencies are checked out for this root - function Lock_File (This : Root) return Absolute_Path with - Pre => This.Is_Valid; + function Lock_File (This : Root) return Absolute_Path; -- The "$crate.lock" file inside Working_Folder private - type Root (Valid : Boolean) is tagged record - case Valid is - when True => - Environment : Properties.Vector; - Path : UString; - Release : Containers.Release_H; - when False => - Reason : UString; - end case; + type Root is tagged record + Environment : Properties.Vector; + Path : UString; + Release : Containers.Release_H; end record; end Alire.Roots; diff --git a/src/alire/alire-workspace.ads b/src/alire/alire-workspace.ads index d1fb5b7b..02c369c1 100644 --- a/src/alire/alire-workspace.ads +++ b/src/alire/alire-workspace.ads @@ -35,8 +35,7 @@ package Alire.Workspace is Containers.Crate_Name_Sets.Empty_Set; Options : Solver.Query_Options := Solver.Default_Options) - return Solutions.Solution - with Pre => Root.Current.Is_Valid; + return Solutions.Solution; -- Compute a new solution for the workspace. If Allowed is not empty, -- crates not appearing in Allowed are held back at their current version. -- This function loads configured indexes from disk. diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 939d65ea..af59d4e7 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -131,19 +131,23 @@ package body Alire is -- Outcome_Failure -- --------------------- - function Outcome_Failure (Message : String) return Outcome is + function Outcome_Failure (Message : String; + Report : Boolean := True) + return Outcome is Stack : constant String := AAA.Debug.Stack_Trace; begin - if Log_Debug then - Err_Log ("Generating Outcome_Failure with message: " & Message); - Err_Log ("Generating Outcome_Failure with call stack:"); - Err_Log (Stack); + if Report then + if Log_Debug then + Err_Log ("Generating Outcome_Failure with message: " & Message); + Err_Log ("Generating Outcome_Failure with call stack:"); + Err_Log (Stack); + end if; + + Trace.Debug ("Generating Outcome_Failure with message: " & Message); + Trace.Debug ("Generating Outcome_Failure with call stack:"); + Trace.Debug (Stack); end if; - Trace.Debug ("Generating Outcome_Failure with message: " & Message); - Trace.Debug ("Generating Outcome_Failure with call stack:"); - Trace.Debug (Stack); - return (Success => False, Message => +Message); end Outcome_Failure; diff --git a/src/alire/alire.ads b/src/alire/alire.ads index 5dfb58e6..26c29b12 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -158,11 +158,14 @@ package Alire with Preelaborate is -- Constructors -- - function Outcome_Failure (Message : String) return Outcome with + function Outcome_Failure (Message : String; + Report : Boolean := True) + return Outcome with Pre => Message'Length > 0, Post => not Outcome_Failure'Result.Success; - -- Calling this function generates a debug stack trace log, so it should - -- not be called until a failure is actually happening. + -- Calling this function generates a debug stack trace log, unless Report + -- is set to False. For failures that are part of regular operation, + -- this is recommended to avoid "scares" in the debug output. function Outcome_Success return Outcome with Post => Outcome_Success'Result.Success; diff --git a/src/alr/alr-bootstrap.adb b/src/alr/alr-bootstrap.adb index 1050a263..7ec72bdb 100644 --- a/src/alr/alr-bootstrap.adb +++ b/src/alr/alr-bootstrap.adb @@ -1,11 +1,10 @@ with Ada.Calendar; -with Alire.Directories; with Alire_Early_Elaboration; with Alire.Index; +with Alire.Root; with Alr.OS_Lib; -with Alr.Root; with Alr.Utils; with GNAT.Ctrl_C; @@ -23,21 +22,6 @@ package body Alr.Bootstrap is OS_Lib.Bailout (1); end Interrupted; - ------------------- - -- Session_State -- - ------------------- - - function Session_State return Session_States is - begin - if Root.Current.Is_Valid then - return Release; - elsif Alire.Directories.Detect_Root_Path /= "" then - return Broken; - else - return Outside; - end if; - end Session_State; - ----------------- -- Status_Line -- ----------------- @@ -49,7 +33,7 @@ package body Alr.Bootstrap is Ada.Calendar.Clock - Alire_Early_Elaboration.Start; begin return - "(" & Session_State'Img & ") (" & + "(" & Utils.To_Lower_Case (Alire.Root.Current.Status'Img) & ") (" & Utils.Trim (Alire.Index.Release_Count'Img) & " releases indexed)" & (" (loaded in" & Milliseconds'Image (Milliseconds (Elapsed)) & "s)"); end Status_Line; diff --git a/src/alr/alr-bootstrap.ads b/src/alr/alr-bootstrap.ads index a78a5cb6..abf6a31b 100644 --- a/src/alr/alr-bootstrap.ads +++ b/src/alr/alr-bootstrap.ads @@ -1,33 +1,6 @@ -with Alire.Types; - -package Alr.Bootstrap is - - --------------------- - -- SESSION STATE -- - --------------------- - - type Session_States is - (Outside, -- Not in any Alire context - Broken, -- Top-level folder is a single release, invalid TOML file - Release, -- Top-level folder is a single release - Sandbox -- Top-level folder is a sandbox with several releases - ); - -- Sandbox mode is not implemented yet - - subtype Valid_Session_States is Session_States range Release .. Sandbox; - - function Session_State return Session_States; - -- Note that even if you're in a release within a sandbox, result is - -- sandbox. - - ------------- - -- OTHER -- - ------------- +package Alr.Bootstrap with Elaborate_Body is function Status_Line return String; -- One-liner reporting most interesting information - function No_Dependencies return Alire.Types.Platform_Dependencies - renames Alire.Types.No_Dependencies; - end Alr.Bootstrap; diff --git a/src/alr/alr-commands-clean.adb b/src/alr/alr-commands-clean.adb index 50e7fe65..26004d84 100644 --- a/src/alr/alr-commands-clean.adb +++ b/src/alr/alr-commands-clean.adb @@ -6,13 +6,10 @@ with Alire.Utils; with Alr.Paths; with Alr.Root; with Alr.Spawn; -with Alr.Bootstrap; with Alr.Platform; package body Alr.Commands.Clean is - use all type Bootstrap.Session_States; - ------------- -- Execute -- ------------- @@ -23,11 +20,9 @@ package body Alr.Commands.Clean is Relocate : constant String := "--relocate-build-tree=" & Alire.Paths.Build_Folder; begin - if not Cmd.Cache then - Requires_Full_Index; - - Requires_Valid_Session; + Requires_Valid_Session; + if not Cmd.Cache then Alr.Root.Current.Export_Build_Environment; Trace.Detail ("Cleaning project and dependencies..."); @@ -49,16 +44,12 @@ package body Alr.Commands.Clean is end if; if Cmd.Cache then - if Bootstrap.Session_State > Outside then - if OS_Lib.Is_Folder (Paths.Alr_Working_Cache_Folder) then - Trace.Detail ("Deleting working copy cache..."); - Ada.Directories.Delete_Tree (Paths.Alr_Working_Cache_Folder); - else - Trace.Detail ("Cache folder not present"); - -- This is expected if the crate has no dependencies - end if; + if OS_Lib.Is_Folder (Paths.Alr_Working_Cache_Folder) then + Trace.Detail ("Deleting working copy cache..."); + Ada.Directories.Delete_Tree (Paths.Alr_Working_Cache_Folder); else - Trace.Info ("Not in a release or sandbox folder"); + Trace.Detail ("Cache folder not present"); + -- This is expected if the crate has no dependencies end if; end if; end Execute; diff --git a/src/alr/alr-commands-get.adb b/src/alr/alr-commands-get.adb index feb77a12..25af6b22 100644 --- a/src/alr/alr-commands-get.adb +++ b/src/alr/alr-commands-get.adb @@ -8,6 +8,7 @@ with Alire.Origins.Deployers; with Alire.Platform; with Alire.Platforms; with Alire.Properties.Actions.Executor; +with Alire.Root; with Alire.Solutions.Diffs; with Alire.Solver; with Alire.Utils.User_Input; @@ -15,7 +16,6 @@ with Alire.Workspace; with Alr.Commands.Build; with Alr.Platform; -with Alr.Bootstrap; with Semantic_Versioning.Extended; @@ -24,8 +24,6 @@ package body Alr.Commands.Get is package Query renames Alire.Solver; package Semver renames Semantic_Versioning; - use all type Bootstrap.Session_States; - -------------- -- Retrieve -- -------------- @@ -79,7 +77,7 @@ package body Alr.Commands.Get is -- Check if we are already in the fresh copy - if Session_State > Outside then + if not Alire.Root.Current.Outside then Reportaise_Command_Failed ("Cannot get a release inside another alr release, stopping."); end if; diff --git a/src/alr/alr-commands-init.adb b/src/alr/alr-commands-init.adb index 7413130f..82b2ec18 100644 --- a/src/alr/alr-commands-init.adb +++ b/src/alr/alr-commands-init.adb @@ -1,11 +1,12 @@ with Ada.Directories; with Ada.Text_IO; +with Alire.Errors; with Alire.Lockfiles; with Alire.Milestones; with Alire.Origins; with Alire.Releases; -with Alire.Roots; +with Alire.Roots.Optional; with Alire.Solutions; with Alire.Workspace; @@ -14,12 +15,9 @@ with Alr.Root; with Alr.Utils; with GNATCOLL.VFS; -with Alr.Bootstrap; package body Alr.Commands.Init is - use all type Bootstrap.Session_States; - Sed_Pattern : constant String := "PROJECT_SKEL"; -------------- @@ -219,6 +217,7 @@ package body Alr.Commands.Init is Check : constant Alire.Milestones.Allowed_Milestones := Alire.Milestones.Crate_Versions (Name) with Unreferenced; + use all type Alire.Roots.Optional.States; begin if Utils.To_Lower_Case (Name) = Utils.To_Lower_Case (Sed_Pattern) then @@ -235,15 +234,29 @@ package body Alr.Commands.Init is -- Create and enter folder for generation, if it didn't happen -- already. - if Session_State = Release then - if Name = Root.Current.Release.Name_Str then - Trace.Info ("Already in working copy, skipping initialization"); - else - Trace.Error ("Cannot initialize a working release inside" - & " another release, stopping."); - raise Command_Failed; - end if; - end if; + declare + Root : constant Alire.Roots.Optional.Root := Alr.Root.Current; + begin + case Root.Status is + when Valid => + if Name = Root.Value.Release.Name_Str then + Trace.Info + ("Already in working copy, skipping initialization"); + else + Reportaise_Command_Failed + ("Cannot initialize a working release inside" + & " another release, stopping."); + end if; + when Broken => + Reportaise_Command_Failed + (Alire.Errors.Wrap + ("Cannot initialize a working release inside" + & " a workspace with invalid metadata", + Root.Message)); + when Outside => + null; + end case; + end; Generate (Cmd); Trace.Detail ("Initialization completed"); diff --git a/src/alr/alr-commands-show.adb b/src/alr/alr-commands-show.adb index 7ee11963..9c75d118 100644 --- a/src/alr/alr-commands-show.adb +++ b/src/alr/alr-commands-show.adb @@ -7,12 +7,12 @@ with Alire.Platforms; with Alire.Properties; with Alire.Releases; with Alire.Requisites.Booleans; -with Alire.Roots; +with Alire.Root; +with Alire.Roots.Optional; with Alire.Solutions; with Alire.Solver; with Alire.Utils.Tables; -with Alr.Bootstrap; with Alr.Platform; with Alr.Root; @@ -201,20 +201,18 @@ package body Alr.Commands.Show is ------------- overriding procedure Execute (Cmd : in out Command) is - use all type Alr.Bootstrap.Session_States; begin if Num_Arguments > 1 then Reportaise_Wrong_Arguments ("Too many arguments"); end if; if Num_Arguments = 0 then - case Bootstrap.Session_State is - when Outside => - Reportaise_Wrong_Arguments - ("Cannot proceed without a crate name"); - when others => - Requires_Valid_Session; - end case; + if Alire.Root.Current.Outside then + Reportaise_Wrong_Arguments + ("Cannot proceed without a crate name"); + else + Requires_Valid_Session; + end if; end if; if Cmd.External and then diff --git a/src/alr/alr-commands-version.adb b/src/alr/alr-commands-version.adb index b14a6b8c..5e2afbbc 100644 --- a/src/alr/alr-commands-version.adb +++ b/src/alr/alr-commands-version.adb @@ -1,6 +1,9 @@ with Alire.Properties; +with Alire.Roots.Optional; +with Alire.Utils.TTY; with Alire.Utils.User_Input; +with Alr.Bootstrap; with Alr.Files; with Alr.OS_Lib; with Alr.Paths; @@ -20,8 +23,10 @@ package body Alr.Commands.Version is overriding procedure Execute (Cmd : in out Command) is pragma Unreferenced (Cmd); use Ada.Text_IO; + Root : constant Alire.Roots.Optional.Root := Alr.Root.Current; + use all type Alire.Roots.Optional.States; begin - Trace.Always ("alr build is " & Bootstrap.Status_Line); + Trace.Always ("alr status is " & Bootstrap.Status_Line); Trace.Always ("config folder is " & Paths.Alr_Config_Folder); Trace.Always ("source folder is " & Paths.Alr_Source_Folder); @@ -30,13 +35,15 @@ package body Alr.Commands.Version is & " force:" & Alire.Force'Img & " not-interactive:" & Alire.Utils.User_Input.Not_Interactive'Img); - if not Root.Current.Is_Valid then - Trace.Always ("alr root is empty"); - else - Trace.Always ("alr root is " & Root.Current.Release.Milestone.Image); - end if; - --- Trace.Always ("alr session hash is " & Session.Hash); + case Root.Status is + when Outside => + Trace.Always ("alr root is empty"); + when Broken => + Trace.Always ("alr root has invalid metadata: " + & Alire.Utils.TTY.Error (Root.Message)); + when Valid => + Trace.Always ("alr root is " & Root.Value.Release.Milestone.Image); + end case; declare Guard : Folder_Guard (Enter_Working_Folder) with Unreferenced; @@ -45,7 +52,8 @@ package body Alr.Commands.Version is OS_Lib.Current_Folder); Trace.Always ("alr is finding" & Files.Locate_Any_GPR_File'Img & " GPR project files"); - Trace.Always ("alr session state is " & Session_State'Img); + Trace.Always + ("alr session state is [" & Root.Status'Img & "]"); end; Log ("alr compiled on [" & diff --git a/src/alr/alr-commands-withing.adb b/src/alr/alr-commands-withing.adb index 73aa42e2..5fdb0045 100644 --- a/src/alr/alr-commands-withing.adb +++ b/src/alr/alr-commands-withing.adb @@ -142,9 +142,9 @@ package body Alr.Commands.Withing is --------------------- procedure Detect_Softlink (Path : String) is - Root : constant Alire.Roots.Root := Alire.Roots.Detect_Root (Path); + Root : constant Alire.Roots.Root := Alire.Roots.Load_Root (Path); begin - if Root.Is_Valid then + if Root.Is_Stored then -- Add a dependency on ^(detected version) (i.e., safely upgradable) Add_Softlink (Dep_Spec => Root.Release.Name_Str @@ -152,7 +152,7 @@ package body Alr.Commands.Withing is Path => Path); else Reportaise_Command_Failed - ("cannot add target: " & Root.Invalid_Reason); + ("cannot add target: " & Root.Storage_Error); end if; end Detect_Softlink; diff --git a/src/alr/alr-commands.adb b/src/alr/alr-commands.adb index ff57f16a..63471b1e 100644 --- a/src/alr/alr-commands.adb +++ b/src/alr/alr-commands.adb @@ -13,8 +13,7 @@ with Alire.Errors; with Alire.Features.Index; with Alire.Lockfiles; with Alire.Platforms; -with Alire.Roots; -with Alire.Roots.Check_Valid; +with Alire.Roots.Optional; with Alire.Solutions; with Alire.Utils.Tables; with Alire.Utils.TTY; @@ -413,61 +412,69 @@ package body Alr.Commands is procedure Requires_Valid_Session (Sync : Boolean := True) is use Alire; - Checked : constant Alire.Roots.Root := - Alire.Roots.Check_Valid (Root.Current); + Unchecked : constant Alire.Roots.Optional.Root := Root.Current; begin - if not Checked.Is_Valid then - Reportaise_Command_Failed - (Errors.Wrap ("Cannot continue with invalid session", - Checked.Invalid_Reason)); + if not Unchecked.Is_Valid then + Raise_Checked_Error + (Alire.Errors.Wrap + ("Cannot continue with invalid session", Unchecked.Message)); end if; - -- For workspaces created pre-lockfiles, or with older format, recreate: + Unchecked.Value.Check_Stored; - case Lockfiles.Validity (Checked.Lock_File) is - when Lockfiles.Valid => - Trace.Debug ("Lockfile at " & Checked.Lock_File & " is valid"); + declare + Checked : constant Roots.Root := Unchecked.Value; + begin - if Sync then - Requires_Full_Index; - Checked.Sync_Solution_And_Deps; - -- Check deps on disk match those in lockfile - end if; + -- For workspaces created pre-lockfiles, or with older format, + -- recreate: - return; -- OK + case Lockfiles.Validity (Checked.Lock_File) is + when Lockfiles.Valid => + Trace.Debug ("Lockfile at " & Checked.Lock_File & " is valid"); - when Lockfiles.Invalid => - Trace.Warning - ("This workspace was created with a previous alr version." - & " Internal data is going to be updated and, as a result," - & " any existing pins will be unpinned and will need to be" - & " manually recreated."); - Alire.Directories.Backup_If_Existing (Checked.Lock_File); - Ada.Directories.Delete_File (Checked.Lock_File); + if Sync then + Requires_Full_Index; + Checked.Sync_Solution_And_Deps; + -- Check deps on disk match those in lockfile + end if; - when Lockfiles.Missing => - Trace.Debug ("Workspace has no lockfile at " & Checked.Lock_File); - end case; + return; -- OK - -- Solve current root dependencies to create the lock file + when Lockfiles.Invalid => + Trace.Warning + ("This workspace was created with a previous alr version." + & " Internal data is going to be updated and, as a result," + & " any existing pins will be unpinned and will need to be" + & " manually recreated."); + Alire.Directories.Backup_If_Existing (Checked.Lock_File); + Ada.Directories.Delete_File (Checked.Lock_File); - Trace.Debug ("Generating lockfile on the fly..."); + when Lockfiles.Missing => + Trace.Debug ("Workspace has no lockfile at " + & Checked.Lock_File); + end case; - declare - Solution : constant Alire.Solutions.Solution := - Alire.Solver.Resolve - (Checked.Release.Dependencies (Platform.Properties), - Platform.Properties, - Alire.Solutions.Empty_Valid_Solution); - begin - Alire.Lockfiles.Write ((Solution => Solution), Checked.Lock_File); + -- Solve current root dependencies to create the lock file - -- Ensure the solved releases are indeed on disk + Trace.Debug ("Generating lockfile on the fly..."); - if Sync then - Requires_Full_Index; - Checked.Sync_Solution_And_Deps; - end if; + declare + Solution : constant Alire.Solutions.Solution := + Alire.Solver.Resolve + (Checked.Release.Dependencies (Platform.Properties), + Platform.Properties, + Alire.Solutions.Empty_Valid_Solution); + begin + Alire.Lockfiles.Write ((Solution => Solution), Checked.Lock_File); + + -- Ensure the solved releases are indeed on disk + + if Sync then + Requires_Full_Index; + Checked.Sync_Solution_And_Deps; + end if; + end; end; end Requires_Valid_Session; diff --git a/src/alr/alr-commands.ads b/src/alr/alr-commands.ads index e9734f66..ddfa4219 100644 --- a/src/alr/alr-commands.ads +++ b/src/alr/alr-commands.ads @@ -4,8 +4,6 @@ with Alire.Directories; with Alire.Solver; with Alire.Utils; -with Alr.Bootstrap; - private with Ada.Text_IO; private with Alire.GPR; @@ -138,10 +136,6 @@ package Alr.Commands is private - -- Session shortcut - function Session_State return Bootstrap.Session_States - renames Bootstrap.Session_State; - -- Facilities for command/argument identification. These are available to -- commands. diff --git a/src/alr/alr-root.adb b/src/alr/alr-root.adb deleted file mode 100644 index b62a046a..00000000 --- a/src/alr/alr-root.adb +++ /dev/null @@ -1,14 +0,0 @@ -with Alire.Root; - -package body Alr.Root is - - ------------- - -- Current -- - ------------- - - function Current return Alire.Roots.Root is - begin - return Alire.Root.Current; - end Current; - -end Alr.Root; diff --git a/src/alr/alr-root.ads b/src/alr/alr-root.ads index 3b82ddb5..be11f00e 100644 --- a/src/alr/alr-root.ads +++ b/src/alr/alr-root.ads @@ -1,8 +1,3 @@ -with Alire.Roots; +with Alire.Root; -package Alr.Root is - -- TODO: delete once global Alire.Root is removed - - function Current return Alire.Roots.Root; - -end Alr.Root; +package Alr.Root renames Alire.Root; -- 2.39.5