diff --git a/src/alire-conditional_values.adb b/src/alire-conditional_values.adb index 7d5e5832..29c27f5f 100644 --- a/src/alire-conditional_values.adb +++ b/src/alire-conditional_values.adb @@ -5,27 +5,38 @@ package body Alire.Conditional_Values is ----------- function "and" (L, R : Conditional_Value) return Conditional_Value is - -- FIXME: we could do an effort to flatten this binary tree that's forming here in longer vectors + Inner : Vector_Inner; + + ------------- + -- Flatten -- + ------------- + + procedure Flatten (This : Inner_Node'Class) is + begin + case This.Kind is + when Value | Condition => + Inner.Values.Append (This); + when Vector => + for Child of Vector_Inner (This).Values loop + Flatten (Child); + end loop; + end case; + end Flatten; + begin - return Result : Conditional_Value do - if L.Is_Empty and then R.Is_Empty then - null; -- nothing to do nor return - else - declare - Inner : Vector_Inner; - begin - if not L.Is_Empty then - Inner.Values.Append (L.Constant_Reference); - end if; + if not L.Is_Empty then + Flatten (L.Constant_Reference); + end if; - if not R.Is_Empty then - Inner.Values.Append (R.Constant_Reference); - end if; + if not R.Is_Empty then + Flatten (R.Constant_Reference); + end if; - Result.Replace_Element (Inner); - end; - end if; - end return; + if Inner.Values.Is_Empty then + return Empty; + else + return (To_Holder (Inner)); + end if; end "and"; -------------- @@ -34,7 +45,7 @@ package body Alire.Conditional_Values is function Evaluate (This : Conditional_Value; Against : Properties.Vector) return Values is - function Evaluate (This : Inner_Value'Class) return Values is + function Evaluate (This : Inner_Node'Class) return Values is begin case This.Kind is when Condition => @@ -82,12 +93,34 @@ package body Alire.Conditional_Values is procedure Iterate_Children (This : Conditional_Value; Visitor : access procedure (CV : Conditional_Value)) is - begin - for Inner of Vector_Inner (This.Constant_Reference.Element.all).Values loop - case Inner.Kind is - when others => BANG + + procedure Iterate (This : Inner_Node'Class) is + begin + case This.Kind is + when Value | Condition => + Visitor (To_Holder (This)); + when Vector => + for Inner of Vector_Inner (This).Values loop + case Inner.Kind is + when Value => + Visitor (New_Value (Value_Inner (Inner).Value)); + when Condition => + declare + Cond : Conditional_Inner renames Conditional_Inner (Inner); + begin + Visitor (New_Conditional (Cond.Condition, Cond.Then_Value, Cond.Else_Value)); + end; + when Vector => + Iterate (Inner); + end case; + end loop; end case; - end loop; + end Iterate; + + begin + if not This.Is_Empty then + Iterate (This.Constant_Reference); + end if; end Iterate_Children; end Alire.Conditional_Values; diff --git a/src/alire-conditional_values.ads b/src/alire-conditional_values.ads index 8181116e..75c94394 100644 --- a/src/alire-conditional_values.ads +++ b/src/alire-conditional_values.ads @@ -26,6 +26,11 @@ package Alire.Conditional_Values with Preelaborate is function Empty return Conditional_Value; + procedure Iterate_Children (This : Conditional_Value; + Visitor : access procedure (CV : Conditional_Value)); + -- Visitor will be called for any immediate non-vector value + -- Vector children will be iterated too, so a flat hierarchy will be mimicked for those + --------------- -- SINGLES -- --------------- @@ -42,10 +47,6 @@ package Alire.Conditional_Values with Preelaborate is function "and" (L, R : Conditional_Value) return Conditional_Value; -- Concatenation - procedure Iterate_Children (This : Conditional_Value; - Visitor : access procedure (CV : Conditional_Value)) - with Pre => This.Kind = Vector; - -------------------- -- CONDITIONALS -- -------------------- @@ -65,25 +66,25 @@ package Alire.Conditional_Values with Preelaborate is private - type Inner_Value is abstract tagged null record; + type Inner_Node is abstract tagged null record; - function Kind (This : Inner_Value'Class) return Kinds; + function Kind (This : Inner_Node'Class) return Kinds; - package Holders is new Ada.Containers.Indefinite_Holders (Inner_Value'Class); - package Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Inner_Value'Class); + package Holders is new Ada.Containers.Indefinite_Holders (Inner_Node'Class); + package Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Inner_Node'Class); type Conditional_Value is new Holders.Holder with null record; -- Instead of dealing with pointers and finalization, we use this class-wide container - type Value_Inner is new Inner_Value with record + type Value_Inner is new Inner_Node with record Value : Values; end record; - type Vector_Inner is new Inner_Value with record + type Vector_Inner is new Inner_Node with record Values : Vectors.Vector; end record; - type Conditional_Inner is new Inner_Value with record + type Conditional_Inner is new Inner_Node with record Condition : Requisites.Tree; Then_Value : Conditional_Value; Else_Value : Conditional_Value; @@ -177,7 +178,7 @@ private -- Kind -- ---------- - function Kind (This : Inner_Value'Class) return Kinds is + function Kind (This : Inner_Node'Class) return Kinds is (if This in Value_Inner'Class then Value else (if This in Vector_Inner'Class diff --git a/src/alire-properties.ads b/src/alire-properties.ads index d107823b..9eaff4d4 100644 --- a/src/alire-properties.ads +++ b/src/alire-properties.ads @@ -13,6 +13,8 @@ package Alire.Properties with Preelaborate is function Image (P : Property) return String is abstract; + function Image_Classwide (P : Property'Class) return String is (P.Image); + package Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Property'Class); type Vector is new Vectors.Vector with null record; diff --git a/src/alire-releases.adb b/src/alire-releases.adb index 3dc381d6..f3ed075f 100644 --- a/src/alire-releases.adb +++ b/src/alire-releases.adb @@ -1,3 +1,5 @@ +with Alire.Conditional_Values; + with GNAT.IO; -- To keep preelaborable package body Alire.Releases is @@ -58,30 +60,43 @@ package body Alire.Releases is end return; end GPR_Files; - -------------------------------- - -- Print_Conditional_Property -- - -------------------------------- + ----------------------- + -- Print_Conditional -- + ----------------------- - procedure Print_Conditional_Property (Cond : Conditional.Properties) is + generic + with package Cond is new Conditional_Values (<>); + with procedure Print (Prefix : String; V : Cond.Values); + procedure Print_Conditional (Prefix : String; This : Cond.Conditional_Value); + + procedure Print_Conditional (Prefix : String; This : Cond.Conditional_Value) is use GNAT.IO; + + procedure Visit (This : Cond.Conditional_Value) is + begin + case This.Kind is + when Cond.Value => + Print (Prefix, This.Value); + when Cond.Condition => + if This.True_Value.Is_Empty then + Put_Line (Prefix & "when not (" & This.Condition.Image & "):"); + Print_Conditional (Prefix & " ", This.False_Value); + else + Put_Line (Prefix & "when " & This.Condition.Image & ":"); + Print_Conditional (Prefix & " ", This.True_Value); + if not This.False_Value.Is_Empty then + Put_Line (Prefix & "else:"); + Print_Conditional (Prefix & " ", This.False_Value); + end if; + end if; + when Cond.Vector => + raise Program_Error with "Shouldn't happen"; + end case; + end Visit; + begin - Put_Line (" (unimplemented)"); --- if Cond.Is_Unconditional then --- Cond.True_Value.Print (Prefix => " "); --- else --- if Cond.True_Value.Is_Empty then --- Put_Line (" when not (" & Cond.Condition.Image & "):"); --- Cond.False_Value.Print (Prefix => " "); --- else --- Put_Line (" when " & Cond.Condition.Image & ":"); --- Cond.True_Value.Print (Prefix => " "); --- if not Cond.False_Value.Is_Empty then --- Put_Line (" else:"); --- Cond.False_Value.Print (Prefix => " "); --- end if; --- end if; --- end if; - end Print_Conditional_Property; + This.Iterate_Children (Visit'Access); + end Print_Conditional; ----------- -- Print -- @@ -89,6 +104,21 @@ package body Alire.Releases is procedure Print (R : Release) is use GNAT.IO; + + procedure Print_Propvec (Prefix : String; V : Properties.Vector) is + begin + Properties.Print (V, Prefix); + end Print_Propvec; + + procedure Print_Depvec (Prefix : String; V : Dependencies.Vectors.Vector) is + begin + for Dep of V loop + Put_Line (Prefix & Dep.Image); + end loop; + end Print_Depvec; + + procedure Print_Properties is new Print_Conditional (Conditional.For_Properties, Print_Propvec); + procedure Print_Dependencies is new Print_Conditional (Conditional.For_Dependencies, Print_Depvec); begin -- MILESTONE Put_Line (R.Milestone.Image & ": " & R.Description); @@ -104,17 +134,13 @@ package body Alire.Releases is -- PROPERTIES if not R.Properties.Is_Empty then Put_Line ("Properties:"); --- for Cond of R.Properties loop --- Print_Conditional_Property (Cond); --- end loop; + Print_Properties (" ", R.Properties); end if; -- DEPENDENCIES if not R.Dependencies.Is_Empty then Put_Line ("Dependencies (direct):"); --- for Dep of R.Depends loop --- Put_Line (" " & Dep.Image); --- end loop; + Print_Dependencies (" ", R.Dependencies); end if; end Print;