From 1be3b218d8120f5d4fc5555737b3717c9003ec75 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Wed, 10 Mar 2021 18:32:45 +0100 Subject: [PATCH] Error scopes (#706) * Initial implementation of error scopes As long as errors are stored with Errors.Set, they will preserve any enclosing error scopes, even when not using a TOML_Adapters.Key_Queue * Fix unreferenced parameters --- .../alire-conditional_trees-toml_load.adb | 3 +- src/alire/alire-dependencies-states.ads | 1 + src/alire/alire-dependencies.adb | 2 + src/alire/alire-dependencies.ads | 1 - src/alire/alire-errors.adb | 69 ++++++++++++++++++- src/alire/alire-errors.ads | 31 +++++++++ src/alire/alire-properties-cases.ads | 2 - src/alire/alire-properties-licenses.adb | 2 +- src/alire/alire-properties-scenarios.adb | 4 +- src/alire/alire-solver.ads | 1 - src/alire/alire-toml_adapters.adb | 34 +++++++-- src/alire/alire-toml_adapters.ads | 33 +++------ src/alire/alire-toml_index.adb | 1 + src/alire/alire-toml_index.ads | 1 - src/alire/alire.adb | 8 ++- 15 files changed, 149 insertions(+), 44 deletions(-) diff --git a/src/alire/alire-conditional_trees-toml_load.adb b/src/alire/alire-conditional_trees-toml_load.adb index 044bcf0c..3eb269d9 100644 --- a/src/alire/alire-conditional_trees-toml_load.adb +++ b/src/alire/alire-conditional_trees-toml_load.adb @@ -1,4 +1,5 @@ with Alire.Conditional_Trees.Case_Nodes; +with Alire.Errors; with Alire.TOML_Keys; package body Alire.Conditional_Trees.TOML_Load is @@ -66,7 +67,7 @@ package body Alire.Conditional_Trees.TOML_Load is ("invalid enumeration value: " & Item_Key); else Trace.Debug - (Case_Table.Message + (Errors.Stack ("unknown enumeration value: " & Item_Key)); end if; end if; diff --git a/src/alire/alire-dependencies-states.ads b/src/alire/alire-dependencies-states.ads index 816edfe2..77107574 100644 --- a/src/alire/alire-dependencies-states.ads +++ b/src/alire/alire-dependencies-states.ads @@ -4,6 +4,7 @@ private with Alire.Containers; with Alire.Externals.Softlinks; with Alire.Properties; with Alire.Releases; +with Alire.TOML_Adapters; package Alire.Dependencies.States is diff --git a/src/alire/alire-dependencies.adb b/src/alire/alire-dependencies.adb index 1da52827..192bae14 100644 --- a/src/alire/alire-dependencies.adb +++ b/src/alire/alire-dependencies.adb @@ -1,3 +1,5 @@ +with Alire.TOML_Adapters; + package body Alire.Dependencies is --------------- diff --git a/src/alire/alire-dependencies.ads b/src/alire/alire-dependencies.ads index 3fcc02fd..729f6c03 100644 --- a/src/alire/alire-dependencies.ads +++ b/src/alire/alire-dependencies.ads @@ -1,6 +1,5 @@ with Alire.Interfaces; with Alire.Milestones; -with Alire.TOML_Adapters; with Alire.Utils; with Semantic_Versioning.Basic; diff --git a/src/alire/alire-errors.adb b/src/alire/alire-errors.adb index 38c51f24..97791057 100644 --- a/src/alire/alire-errors.adb +++ b/src/alire/alire-errors.adb @@ -1,3 +1,4 @@ +with Ada.Containers.Indefinite_Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with Alire.Utils; @@ -72,7 +73,9 @@ package body Alire.Errors is function Set (Text : String) return String is Id : Positive; begin - Store.Set (Text, Id); + -- When we store an error, we do so with the current error stack + Store.Set (Stack (Text), Id); + return Id_Marker & Utils.Trim (Id'Img); end Set; @@ -149,4 +152,68 @@ package body Alire.Errors is function Wrap (Upper, Lower : String) return String is (Upper & ASCII.LF & Lower); + -------------------- + -- ERROR STACKING -- + -------------------- + + package String_Lists is + new Ada.Containers.Indefinite_Doubly_Linked_Lists (String); + + Error_Stack : String_Lists.List; + + ---------- + -- Open -- + ---------- + + function Open (Text : String) return Scope is + begin + Error_Stack.Append (Text); + return (Ada.Finalization.Limited_Controlled with null record); + end Open; + + ---------- + -- Open -- + ---------- + + procedure Open (Text : String) is + begin + Error_Stack.Append (Text); + end Open; + + ----------- + -- Close -- + ----------- + + procedure Close is + begin + Error_Stack.Delete_Last; + end Close; + + -------------- + -- Finalize -- + -------------- + + overriding + procedure Finalize (This : in out Scope) is + pragma Unreferenced (This); + begin + Close; + end Finalize; + + ----------- + -- Stack -- + ----------- + + function Stack (Text : String) return String + is + Msg : UString; + use UStrings; + begin + for Item of Error_Stack loop + Append (Msg, Item & ASCII.LF); + end loop; + + return +Msg & Text; + end Stack; + end Alire.Errors; diff --git a/src/alire/alire-errors.ads b/src/alire/alire-errors.ads index 2bcc5970..fef57697 100644 --- a/src/alire/alire-errors.ads +++ b/src/alire/alire-errors.ads @@ -1,4 +1,5 @@ with Ada.Exceptions; +private with Ada.Finalization; package Alire.Errors with Preelaborate is @@ -71,10 +72,40 @@ package Alire.Errors with Preelaborate is -- Convenience to concatenate two error messages: a new wrapping text and -- an existing error within a exception being wrapped. + ----------- + -- Scope -- + ----------- + + type Scope (<>) is limited private; + -- A type to create a stack of error information. When Errors.Set is used, + -- the whole error stack is stored. Manages scope closing automatically. + + function Open (Text : String) return Scope; + -- Push a new message into the error stack + + procedure Open (Text : String); + -- Manually open a scope; used to blend seamlessly the TOML_Adapters. + -- Should not be used otherwise. + + procedure Close; + -- As for Open; don't use manually. + + function Stack (Text : String) return String; + -- Return current error stack, plus Text as the latest error + private Id_Marker : constant String := "alire-stored-error:"; + type Scope is new Ada.Finalization.Limited_Controlled with null record; + + overriding + procedure Finalize (This : in out Scope); + + ----------------- + -- Is_Error_Id -- + ----------------- + function Is_Error_Id (Str : String) return Boolean is (Str'Length > Id_Marker'Length and then Str (Str'First .. Str'First + Id_Marker'Length - 1) = Id_Marker); diff --git a/src/alire/alire-properties-cases.ads b/src/alire/alire-properties-cases.ads index 125a8324..d79925e9 100644 --- a/src/alire/alire-properties-cases.ads +++ b/src/alire/alire-properties-cases.ads @@ -1,5 +1,3 @@ -with Alire.TOML_Adapters; - with TOML; generic diff --git a/src/alire/alire-properties-licenses.adb b/src/alire/alire-properties-licenses.adb index e5c613df..b4625c06 100644 --- a/src/alire/alire-properties-licenses.adb +++ b/src/alire/alire-properties-licenses.adb @@ -97,7 +97,7 @@ package body Alire.Properties.Licenses is begin if Value.Kind = TOML_Array then Warnings.Warn_Once - (From.Message + (Errors.Stack ("Array of license in manifest is deprecated. " & "License should be a single string containing a " & "valid SPDX expression (https://spdx.org/licenses/)")); diff --git a/src/alire/alire-properties-scenarios.adb b/src/alire/alire-properties-scenarios.adb index 6fac32d6..b8b96a63 100644 --- a/src/alire/alire-properties-scenarios.adb +++ b/src/alire/alire-properties-scenarios.adb @@ -1,3 +1,5 @@ +with Alire.Errors; + package body Alire.Properties.Scenarios is --------------- @@ -127,7 +129,7 @@ package body Alire.Properties.Scenarios is (if +From.Unwrap.Keys (1) = TOML_Keys.GPR_Set_Ext then From_TOML (From) else raise Checked_Error with - From.Message ("scenario expressions can only set externals")); + Errors.Stack ("scenario expressions can only set externals")); ------------- -- To_TOML -- diff --git a/src/alire/alire-solver.ads b/src/alire/alire-solver.ads index 91766302..caf0aedf 100644 --- a/src/alire/alire-solver.ads +++ b/src/alire/alire-solver.ads @@ -2,7 +2,6 @@ with Alire.Dependencies; with Alire.Index; with Alire.Properties; with Alire.Solutions; -with Alire.TOML_Adapters; with Alire.Types; with Semantic_Versioning.Extended; diff --git a/src/alire/alire-toml_adapters.adb b/src/alire/alire-toml_adapters.adb index e111c835..30f5778c 100644 --- a/src/alire/alire-toml_adapters.adb +++ b/src/alire/alire-toml_adapters.adb @@ -1,5 +1,19 @@ +with Alire.Errors; + package body Alire.TOML_Adapters is + -------------- + -- Finalize -- + -------------- + + overriding + procedure Finalize (This : in out Key_Queue) is + pragma Unreferenced (This); + begin + -- Manually close this error scope + Errors.Close; + end Finalize; + ------------ -- Assert -- ------------ @@ -36,7 +50,7 @@ package body Alire.TOML_Adapters is procedure Checked_Error (Queue : Key_Queue; Message : String) is begin - raise Alire.Checked_Error with Errors.Set (Queue.Message (Message)); + raise Alire.Checked_Error with Errors.Set (Message); end Checked_Error; ----------------------- @@ -49,7 +63,7 @@ package body Alire.TOML_Adapters is is begin if Recover then - Recoverable_Error (Queue.Message (Message), Recover); + Recoverable_Error (Message, Recover); else Queue.Checked_Error (Message); end if; @@ -91,8 +105,15 @@ package body Alire.TOML_Adapters is ---------- function From (Value : TOML.TOML_Value; - Context : String) return Key_Queue is - (Value, +Context); + Context : String) return Key_Queue + is + begin + return This : constant Key_Queue := + (Ada.Finalization.Limited_Controlled with Value => Value) + do + Errors.Open (Context); + end return; + end From; ---------- -- From -- @@ -111,7 +132,7 @@ package body Alire.TOML_Adapters is function Descend (Parent : Key_Queue; Value : TOML.TOML_Value; Context : String) return Key_Queue is - (From (Value, (+Parent.Context) & ASCII.LF & Context)); + (From (Value, Context)); --------- -- Pop -- @@ -247,8 +268,7 @@ package body Alire.TOML_Adapters is function Report_Extra_Keys (Queue : Key_Queue) return Outcome is use UStrings; - Message : UString := +Errors.Wrap (+Queue.Context, - "forbidden extra entries: "); + Message : UString := +"forbidden extra entries: "; Is_First : Boolean := True; Errored : Boolean := False; begin diff --git a/src/alire/alire-toml_adapters.ads b/src/alire/alire-toml_adapters.ads index bb79270f..ddd97c73 100644 --- a/src/alire/alire-toml_adapters.ads +++ b/src/alire/alire-toml_adapters.ads @@ -1,4 +1,5 @@ -with Alire.Errors; +private with Ada.Finalization; + with Alire.Utils; with TOML; use all type TOML.Any_Value_Kind; @@ -12,13 +13,11 @@ package Alire.TOML_Adapters with Preelaborate is Post => Create_Table'Result.Kind in TOML.TOML_Table; -- Create a table with a single key and value - type Key_Queue is tagged private; + type Key_Queue is tagged limited private; -- Helper type that simplifies keeping track of processed keys during load. -- Also encapsulates a context that can be used to pinpoint errors better. -- Note: all operations on this type use shallow copies! - function Empty_Queue return Key_Queue; - function From (Key : String; Value : TOML.TOML_Value; Context : String) return Key_Queue; @@ -42,9 +41,6 @@ package Alire.TOML_Adapters with Preelaborate is return Key_Queue; -- Use Parent for previous context, wrapping a key = value table. - function Message (Queue : Key_Queue; Message : String) return String; - -- Returns Queue's context & ": " & extra message. - function Failure (Queue : Key_Queue; Message : String) return Outcome with Post => not Failure'Result.Success; -- Return a failed Outcome, using the Context & Message as information. @@ -162,18 +158,12 @@ package Alire.TOML_Adapters with Preelaborate is private - type Key_Queue is tagged record + type Key_Queue is new Ada.Finalization.Limited_Controlled with record Value : TOML.TOML_Value; - Context : UString; end record; - ----------------- - -- Empty_Queue -- - ----------------- - - function Empty_Queue return Key_Queue is - (Value => TOML.No_TOML_Value, - Context => <>); + overriding + procedure Finalize (This : in out Key_Queue); ------------ -- Unwrap -- @@ -186,26 +176,19 @@ private -- Descend -- ------------- - function Message (Queue : Key_Queue; Message : String) return String is - (Errors.Wrap (+Queue.Context, Message)); - - ------------- - -- Descend -- - ------------- - function Descend (Parent : Key_Queue; Key : String; Value : TOML.TOML_Value; Context : String) return Key_Queue is - (From (Key, Value, Parent.Message (Context))); + (From (Key, Value, Context)); ------------- -- Failure -- ------------- function Failure (Queue : Key_Queue; Message : String) return Outcome is - (Outcome_Failure (Queue.Message (Message))); + (Outcome_Failure (Message)); ----------- -- Adafy -- diff --git a/src/alire/alire-toml_index.adb b/src/alire/alire-toml_index.adb index 589fb62f..0983c0e1 100644 --- a/src/alire/alire-toml_index.adb +++ b/src/alire/alire-toml_index.adb @@ -3,6 +3,7 @@ with Ada.Directories; with Alire.Directories; with Alire.Errors; with Alire.GPR; +with Alire.TOML_Adapters; with Alire.Hashes.SHA512_Impl; pragma Unreferenced (Alire.Hashes.SHA512_Impl); -- Hash implementation generics are not directly withed anywhere. Since they diff --git a/src/alire/alire-toml_index.ads b/src/alire/alire-toml_index.ads index 6a032b0c..da4c44d7 100644 --- a/src/alire/alire-toml_index.ads +++ b/src/alire/alire-toml_index.ads @@ -3,7 +3,6 @@ private with TOML; with Alire.Index_On_Disk; with Alire.Crates; with Alire.Releases; -with Alire.TOML_Adapters; with Semantic_Versioning; diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 9bd7b957..e270167a 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -156,18 +156,20 @@ package body Alire is begin if Report then if Log_Debug then - Err_Log ("Generating Outcome_Failure with message: " & Message); + Err_Log ("Generating Outcome_Failure with message: " + & Errors.Stack (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 message: " + & Errors.Stack (Message)); Trace.Debug ("Generating Outcome_Failure with call stack:"); Trace.Debug (Stack); end if; return (Success => False, - Message => +Message); + Message => +Errors.Stack (Message)); end Outcome_Failure; ---------------------------- -- 2.39.5