Merge pull request #2316 from dkm/pr/ada_syntax

Add syntax support for Ada

.gitmodules

@@ -244,3 +244,6 @@
 	url = https://github.com/victor-gp/cmd-help-sublime-syntax.git
 	branch = main
 	shallow = true
+[submodule "assets/syntaxes/02_Extra/Ada"]
+	path = assets/syntaxes/02_Extra/Ada
+	url = https://github.com/wiremoons/ada-sublime-syntax

tests/syntax-tests/highlighted/Ada/click.gpr

@@ -0,0 +1,29 @@
+with "config/click_config.gpr";
+project Click is
+
+   for Library_Name use "Click";
+   for Library_Version use Project'Library_Name & ".so." & Click_Config.Crate_Version;
+
+   for Source_Dirs use ("src/", "config/");
+   for Object_Dir use "obj/" & Click_Config.Build_Profile;
+   for Create_Missing_Dirs use "True";
+   for Library_Dir use "lib";
+
+   type Library_Type_Type is ("relocatable", "static", "static-pic");
+   Library_Type : Library_Type_Type :=
+     external ("CLICK_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static"));
+   for Library_Kind use Library_Type;
+
+   package Compiler is
+      for Default_Switches ("Ada") use Click_Config.Ada_Compiler_Switches & ("-gnatX", "-gnat2022");
+   end Compiler;
+
+   package Binder is
+      for Switches ("Ada") use ("-Es"); --  Symbolic traceback
+   end Binder;
+
+   package Install is
+      for Artifacts (".") use ("share");
+   end Install;
+
+end Click;

tests/syntax-tests/source/Ada/LICENSE.md

@@ -0,0 +1,23 @@
+The files `click.adb`, `click.ads` and `click.gpr` have been added from https://github.com/dkm/click under the following license:
+
+MIT License
+
+Copyright (c) 2022 Marc Poulhiès <dkm@kataplop.net>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

tests/syntax-tests/source/Ada/click.adb

@@ -0,0 +1,308 @@
+with Chests.Ring_Buffers;
+with USB.Device.HID.Keyboard;
+
+package body Click is
+   ----------------
+   --  DEBOUNCE  --
+   ----------------
+
+   --  Ideally, in a separate package.
+
+   --  should be [], but not fixed yet in GCC 11.
+   Current_Status : Key_Matrix := [others => [others => False]];
+   New_Status : Key_Matrix := [others => [others => False]];
+   Since : Natural := 0;
+   --   Nb_Bounce : Natural := 5;
+
+   function Update (NewS : Key_Matrix) return Boolean is
+   begin
+      --  The new state is the same as the current stable state => Do nothing.
+      if Current_Status = NewS then
+         Since := 0;
+         return False;
+      end if;
+
+      if New_Status /= NewS then
+         --  The new state differs from the previous
+         --  new state (bouncing) => reset
+         New_Status := NewS;
+         Since := 1;
+      else
+         --  The new state hasn't changed since last
+         --  update => towards stabilization.
+         Since := Since + 1;
+      end if;
+
+      if Since > Nb_Bounce then
+         declare
+            Tmp : constant Key_Matrix := Current_Status;
+         begin
+            --  New state has been stable enough.
+            --  Latch it and notifies caller.
+            Current_Status := New_Status;
+            New_Status := Tmp;
+            Since := 0;
+         end;
+
+         return True;
+      else
+         --  Not there yet
+         return False;
+      end if;
+   end Update;
+
+   procedure Get_Matrix;
+   --  Could use := []; but GNAT 12 has a bug (fixed in upcoming 13)
+   Read_Status : Key_Matrix := [others => [others => False]];
+
+   function Get_Events return Events is
+      Num_Evt : Natural := 0;
+      New_S : Key_Matrix renames Read_Status;
+   begin
+      Get_Matrix;
+      if Update (New_S) then
+         for I in Current_Status'Range (1) loop
+            for J in Current_Status'Range (2) loop
+               if (not New_Status (I, J) and then Current_Status (I, J))
+                 or else (New_Status (I, J) and then not Current_Status (I, J))
+               then
+                  Num_Evt := Num_Evt + 1;
+               end if;
+            end loop;
+         end loop;
+
+         declare
+            Evts : Events (Natural range 1 .. Num_Evt);
+            Cursor : Natural range 1 .. Num_Evt + 1 := 1;
+         begin
+            for I in Current_Status'Range (1) loop
+               for J in Current_Status'Range (2) loop
+                  if not New_Status (I, J)
+                    and then Current_Status (I, J)
+                  then
+                     --  Pressing I, J
+                     Evts (Cursor) := [
+                                       Evt => Press,
+                                       Col => I,
+                                       Row => J
+                                      ];
+                     Cursor := Cursor + 1;
+                  elsif New_Status (I, J)
+                    and then not Current_Status (I, J)
+                  then
+                     --  Release I, J
+                     Evts (Cursor) := [
+                                       Evt => Release,
+                                       Col => I,
+                                       Row => J
+                                      ];
+                     Cursor := Cursor + 1;
+                  end if;
+               end loop;
+            end loop;
+            return Evts;
+         end;
+      end if;
+
+      return [];
+   end Get_Events;
+
+   procedure Get_Matrix  is -- return Key_Matrix is
+   begin
+      for Row in Keys.Rows'Range loop
+         Keys.Rows (Row).Clear;
+
+         for Col in Keys.Cols'Range loop
+            Read_Status (Col, Row) := not Keys.Cols (Col).Set;
+         end loop;
+         Keys.Rows (Row).Set;
+      end loop;
+   end Get_Matrix;
+
+   --  End of DEBOUNCE
+
+   --------------
+   --  Layout  --
+   --------------
+
+   package Events_Ring_Buffers is new Chests.Ring_Buffers
+     (Element_Type => Event,
+      Capacity     => 16);
+
+   Queued_Events : Events_Ring_Buffers.Ring_Buffer;
+
+   type Statet is (Normal_Key, Layer_Mod, None);
+   type State is record
+      Typ : Statet;
+      Code : Key_Code_T;
+      Layer_Value : Natural;
+      --  Col : ColR;
+      --  Row : RowR;
+   end record;
+
+   type State_Array is array (ColR, RowR) of State;
+   States : State_Array := [others => [others => (Typ => None, Code => No, Layer_Value => 0)]];
+
+   function Kw (Code : Key_Code_T) return Action is
+   begin
+      return (T => Key, C => Code, L => 0);
+   end Kw;
+
+   function Lw (V : Natural) return Action is
+   begin
+      return (T => Layer, C => No, L => V);
+   end Lw;
+
+   --  FIXME: hardcoded max number of events
+   subtype Events_Range is Natural range 0 .. 60;
+   type Array_Of_Reg_Events is array (Events_Range) of Event;
+
+   Stamp : Natural := 0;
+
+   procedure Register_Events (L : Layout; Es : Events) is
+   begin
+      Stamp := Stamp + 1;
+
+      Log ("Reg events: " & Stamp'Image);
+      Log (Es'Length'Image);
+      for E of Es loop
+         declare
+         begin
+            if Events_Ring_Buffers.Is_Full (Queued_Events) then
+               raise Program_Error;
+            end if;
+
+            Events_Ring_Buffers.Append (Queued_Events, E);
+         end;
+         --         Log ("Reg'ed events:" &  Events_Mark'Image);
+         Log ("Reg'ed events:" &  Events_Ring_Buffers.Length (Queued_Events)'Image);
+      end loop;
+   end Register_Events;
+
+   procedure Release (Col: Colr; Row: Rowr) is
+   begin
+      if States (Col, Row).Typ = None then
+         raise Program_Error;
+      end if;
+      States (Col, Row) := (Typ => None, Code => No, Layer_Value => 0);
+   end Release;
+
+   function Get_Current_Layer return Natural is
+      L : Natural := 0;
+   begin
+      for S of States loop
+         if S.Typ = Layer_Mod then
+            L := L + S.Layer_Value;
+         end if;
+      end loop;
+
+      return L;
+   end Get_Current_Layer;
+
+   --  Tick the event.
+   --  Returns TRUE if it needs to stay in the queued events
+   --  FALSE if the event has been consumed.
+
+   function Tick (L: Layout; E : in out Event) return Boolean is
+      Current_Layer : Natural := Get_Current_Layer;
+      A : Action renames L (Current_Layer, E.Row, E.Col);
+   begin
+      case E.Evt is
+         when Press =>
+            case A.T is
+               when Key =>
+                  States (E.Col, E.Row) :=
+                    (Typ => Normal_Key,
+                     Code => A.C,
+                     Layer_Value => 0);
+               when Layer =>
+                  States (E.Col, E.Row) := (Typ => Layer_Mod, Layer_Value => A.L, Code => No);
+               when others =>
+                  raise Program_Error;
+            end case;
+
+         when Release =>
+            Release (E.Col, E.Row);
+      end case;
+      return False;
+   end Tick;
+
+   Last_Was_Empty_Log : Boolean := False;
+
+   procedure Tick (L : Layout) is
+   begin
+      for I in 1 .. Events_Ring_Buffers.Length(Queued_Events) loop
+         declare
+            E : Event := Events_Ring_Buffers.Last_Element (Queued_Events);
+         begin
+            Events_Ring_Buffers.Delete_Last (Queued_Events);
+            if Tick (L, E) then
+               Events_Ring_Buffers.Prepend (Queued_Events, E);
+            end if;
+         end;
+      end loop;
+      if not Last_Was_Empty_Log or else Events_Ring_Buffers.Length(Queued_Events) /= 0 then
+         Log ("End Tick layout, events: " & Events_Ring_Buffers.Length(Queued_Events)'Image);
+         Last_Was_Empty_Log := Events_Ring_Buffers.Length(Queued_Events) = 0;
+      end if;
+   end Tick;
+
+   function Get_Key_Codes return Key_Codes_T is
+      Codes : Key_Codes_T (0 .. 10);
+      Wm: Natural := 0;
+   begin
+      for S of States loop
+         if S.Typ = Normal_Key and then
+            (S.Code < LCtrl or else S.Code > RGui)
+         then
+            Codes (Wm) := S.Code;
+            Wm := Wm + 1;
+         end if;
+      end loop;
+
+      if Wm = 0 then
+         return [];
+      else
+         return Codes (0 .. Wm - 1);
+      end if;
+   end Get_Key_Codes;
+
+   function Get_Modifiers return Key_Modifiers is
+      use USB.Device.HID.Keyboard;
+      KM : Key_Modifiers (1..8);
+      I : Natural := 0;
+   begin
+      for S of States loop
+         if S.Typ = Normal_Key then
+            I := I + 1;
+            case S.Code is
+              when LCtrl =>
+                 KM(I) := Ctrl_Left;
+              when RCtrl =>
+                 KM(I) := Ctrl_Right;
+              when LShift =>
+                 KM(I) := Shift_Left;
+              when RShift =>
+                 KM(I) := Shift_Right;
+              when LAlt =>
+                 KM(I) := Alt_Left;
+              when RAlt =>
+                 KM(I) := Alt_Right;
+              when LGui =>
+                 KM(I) := Meta_Left;
+              when RGui =>
+                 KM(I) := Meta_Right;
+              when others =>
+                 I := I - 1;
+            end case;
+         end if;
+      end loop;
+      return KM (1..I);
+   end Get_Modifiers;
+
+   procedure Init is
+   begin
+      Events_Ring_Buffers.Clear (Queued_Events);
+   end Init;
+
+end Click;