MirroredRepos/bat
1
0
Fork 0
mirror of https://github.com/sharkdp/bat.git synced 2025-10-31 15:12:12 +00:00
Code Issues Releases Wiki Activity

Merge pull request #2316 from dkm/pr/ada_syntax

Browse Source 
Add syntax support for Ada
This commit is contained in:
David Peter
2022-10-30 19:56:07 +01:00
committed by GitHub
parent 3c9c960612 06b403aa92
commit 8e15c9c501
9 changed files with 1379 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

308
tests/syntax-tests/highlighted/Ada/click.adb vendored Normal file
View File

@@ -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;

339
tests/syntax-tests/highlighted/Ada/click.ads vendored Normal file
View File

@@ -0,0 +1,339 @@
with HAL.GPIO;
with USB.Device.HID.Keyboard;
generic
 Nb_Bounce : Natural;
 type ColR is (<>);
 type RowR is (<>);
 type GPIOP is new HAL.GPIO.GPIO_Point with private;
 type Cols_T is array (ColR) of GPIOP;
 type Rows_T is array (RowR) of GPIOP;
 Cols : Cols_T;
 Rows : Rows_T;
 Num_Layers : Natural;
 with procedure Log (S : String; L : Integer := 1; Deindent : Integer := 0);
package Click is
 type Keys_T is record
 Cols : Cols_T;
 Rows : Rows_T;
 end record;
 Keys : Keys_T :=
 (Rows => Rows, Cols => Cols);
 type Key_Matrix is array (ColR, RowR) of Boolean;
 --------------------------
 -- Events & Debouncing --
 --------------------------
 MaxEvents : constant Positive := 20;
 type EventT is (Press, Release);
 type Event is record
 Evt : EventT;
 Col : ColR;
 Row : RowR;
 end record;
 type Events is array (Natural range <>) of Event;
 function Get_Events return Events;
 function Update (NewS : Key_Matrix) return Boolean;
 -------------
 -- Layout --
 -------------
 ---------------
 -- Keycodes --
 ---------------
 -- Keycodes copy/pasted from the excelent Keyberon Rust firmware:
 -- https://github.com/TeXitoi/keyberon/
 type Key_Code_T is
 (
 -- The "no" key, a placeholder to express nothing.
 No, -- = 0x00,
 -- / Error if too much keys are pressed at
 -- the same time.
 ErrorRollOver,
 -- / The POST fail error.
 PostFail,
 -- / An undefined error occured.
 ErrorUndefined,
 -- / `a` and `A`.
 A,
 B,
 C,
 D,
 E,
 F,
 G,
 H,
 I,
 J,
 K,
 L,
 M, -- 0x10
 N,
 O,
 P,
 Q,
 R,
 S,
 T,
 U,
 V,
 W,
 X,
 Y,
 Z,
 -- `1` and `!`.
 Kb1,
 -- `2` and `@`.
 Kb2,
 -- `3` and `#`.
 Kb3, -- 0x20
 -- / `4` and `$`.
 Kb4,
 -- `5` and `%`.
 Kb5,
 -- `6` and `^`.
 Kb6,
 -- `7` and `&`.
 Kb7,
 -- `8` and `*`.
 Kb8,
 -- `9` and `(`.
 Kb9,
 -- `0` and `)`.
 Kb0,
 Enter,
 Escape,
 BSpace,
 Tab,
 Space,
 -- `-` and `_`.
 Minus,
 -- `=` and `+`.
 Equal,
 -- `[` and `{`.
 LBracket,
 -- `]` and `}`.
 RBracket, -- 0x30
 -- / `\` and `|`.
 Bslash,
 -- Non-US `#` and `~` (Typically near the Enter key).
 NonUsHash,
 -- `;` and `:`.
 SColon,
 -- `'` and `"`.
 Quote,
 -- How to have ` as code?
 -- \` and `~`.
 Grave,
 -- `,` and `<`.
 Comma,
 -- `.` and `>`.
 Dot,
 -- `/` and `?`.
 Slash,
 CapsLock,
 F1,
 F2,
 F3,
 F4,
 F5,
 F6,
 F7, -- 0x40
 F8,
 F9,
 F10,
 F11,
 F12,
 PScreen,
 ScrollLock,
 Pause,
 Insert,
 Home,
 PgUp,
 Delete,
 Endd,
 PgDown,
 Right,
 Left, -- 0x50
 Down,
 Up,
 NumLock,
 -- Keypad `/`
 KpSlash,
 -- Keypad `*`
 KpAsterisk,
 -- Keypad `-`.
 KpMinus,
 -- Keypad `+`.
 KpPlus,
 -- Keypad enter.
 KpEnter,
 -- Keypad 1.
 Kp1,
 Kp2,
 Kp3,
 Kp4,
 Kp5,
 Kp6,
 Kp7,
 Kp8, -- 0x60
 Kp9,
 Kp0,
 KpDot,
 -- Non-US `\` and `|` (Typically near the Left-Shift key)
 NonUsBslash,
 Application, -- 0x65
 -- / not a key, used for errors
 Power,
 -- Keypad `=`.
 KpEqual,
 F13,
 F14,
 F15,
 F16,
 F17,
 F18,
 F19,
 F20,
 F21, -- 0x70
 F22,
 F23,
 F24,
 Execute,
 Help,
 Menu,
 Selectt,
 Stop,
 Again,
 Undo,
 Cut,
 Copy,
 Paste,
 Find,
 Mute,
 VolUp, -- 0x80
 VolDown,
 -- Deprecated.
 LockingCapsLock,
 -- Deprecated.
 LockingNumLock,
 -- Deprecated.
 LockingScrollLock,
 -- / Keypad `,`, also used for the
 -- brazilian keypad period (.) key.
 KpComma,
 -- Used on AS/400 keyboard
 KpEqualSign,
 Intl1,
 Intl2,
 Intl3,
 Intl4,
 Intl5,
 Intl6,
 Intl7,
 Intl8,
 Intl9,
 Lang1, -- 0x90
 Lang2,
 Lang3,
 Lang4,
 Lang5,
 Lang6,
 Lang7,
 Lang8,
 Lang9,
 AltErase,
 SysReq,
 Cancel,
 Clear,
 Prior,
 Returnn,
 Separator,
 Outt, -- 0xA0
 Oper,
 ClearAgain,
 CrSel,
 ExSel,
 -- According to QMK, 0xA5-0xDF are not
 -- usable on modern keyboards
 -- Modifiers
 -- Left Control.
 LCtrl, -- = 0xE0,
 -- / Left Shift.
 LShift,
 -- Left Alt.
 LAlt,
 -- Left GUI (the Windows key).
 LGui,
 -- Right Control.
 RCtrl,
 -- Right Shift.
 RShift,
 -- Right Alt (or Alt Gr). 
 RAlt,
 -- Right GUI (the Windows key).
 RGui, -- 0xE7
 -- Unofficial
 MediaPlayPause, -- 0xE8,
 MediaStopCD,
 MediaPreviousSong,
 MediaNextSong,
 MediaEjectCD,
 MediaVolUp,
 MediaVolDown,
 MediaMute,
 MediaWWW, -- 0xF0
 MediaBack,
 MediaForward,
 MediaStop,
 MediaFind,
 MediaScrollUp,
 MediaScrollDown,
 MediaEdit,
 MediaSleep,
 MediaCoffee,
 MediaRefresh,
 MediaCalc -- 0xFB
 );
 type Action_Type is (Key, No_Op, Trans, Layer, Multiple_Actions);
 -- Should be a discriminated type
 type Action is record
 T : Action_Type; -- hould be the discriminant
 C : Key_Code_T;
 L : Natural;
 end record;
 function Kw (Code : Key_Code_T) return Action;
 function Lw (V : Natural) return Action;
 type Key_Modifiers is array (Natural range <>) of USB.Device.HID.Keyboard.Modifiers;
 type Key_Codes_T is array (Natural range <>) of Key_Code_T;
 subtype Ac is Action;
 type Layout is array (0 .. Num_Layers - 1, RowR, ColR) of Action;
 procedure Register_Events (L : Layout; Es : Events);
 procedure Tick (L : Layout);
 function Get_Key_Codes return Key_Codes_T;
 function Get_Modifiers return Key_Modifiers;
 procedure Init;
end Click;

29
tests/syntax-tests/highlighted/Ada/click.gpr vendored Normal file
View File

@@ -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;

23
tests/syntax-tests/source/Ada/LICENSE.md vendored Normal file
View File

@@ -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.

308
tests/syntax-tests/source/Ada/click.adb vendored Normal file
View File

@@ -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;

339
tests/syntax-tests/source/Ada/click.ads vendored Normal file
View File

@@ -0,0 +1,339 @@
with HAL.GPIO;
with USB.Device.HID.Keyboard;
generic
Nb_Bounce : Natural;
type ColR is (<>);
type RowR is (<>);
type GPIOP is new HAL.GPIO.GPIO_Point with private;
type Cols_T is array (ColR) of GPIOP;
type Rows_T is array (RowR) of GPIOP;
Cols : Cols_T;
Rows : Rows_T;
Num_Layers : Natural;
with procedure Log (S : String; L : Integer := 1; Deindent : Integer := 0);
package Click is
type Keys_T is record
Cols : Cols_T;
Rows : Rows_T;
end record;
Keys : Keys_T :=
(Rows => Rows, Cols => Cols);
type Key_Matrix is array (ColR, RowR) of Boolean;
--------------------------
-- Events & Debouncing --
--------------------------
MaxEvents : constant Positive := 20;
type EventT is (Press, Release);
type Event is record
Evt : EventT;
Col : ColR;
Row : RowR;
end record;
type Events is array (Natural range <>) of Event;
function Get_Events return Events;
function Update (NewS : Key_Matrix) return Boolean;
-------------
-- Layout --
-------------
---------------
-- Keycodes --
---------------
-- Keycodes copy/pasted from the excelent Keyberon Rust firmware:
-- https://github.com/TeXitoi/keyberon/
type Key_Code_T is
(
-- The "no" key, a placeholder to express nothing.
No, -- = 0x00,
-- / Error if too much keys are pressed at
-- the same time.
ErrorRollOver,
-- / The POST fail error.
PostFail,
-- / An undefined error occured.
ErrorUndefined,
-- / `a` and `A`.
A,
B,
C,
D,
E,
F,
G,
H,
I,
J,
K,
L,
M, -- 0x10
N,
O,
P,
Q,
R,
S,
T,
U,
V,
W,
X,
Y,
Z,
-- `1` and `!`.
Kb1,
-- `2` and `@`.
Kb2,
-- `3` and `#`.
Kb3, -- 0x20
-- / `4` and `$`.
Kb4,
-- `5` and `%`.
Kb5,
-- `6` and `^`.
Kb6,
-- `7` and `&`.
Kb7,
-- `8` and `*`.
Kb8,
-- `9` and `(`.
Kb9,
-- `0` and `)`.
Kb0,
Enter,
Escape,
BSpace,
Tab,
Space,
-- `-` and `_`.
Minus,
-- `=` and `+`.
Equal,
-- `[` and `{`.
LBracket,
-- `]` and `}`.
RBracket, -- 0x30
-- / `\` and `|`.
Bslash,
-- Non-US `#` and `~` (Typically near the Enter key).
NonUsHash,
-- `;` and `:`.
SColon,
-- `'` and `"`.
Quote,
-- How to have ` as code?
-- \` and `~`.
Grave,
-- `,` and `<`.
Comma,
-- `.` and `>`.
Dot,
-- `/` and `?`.
Slash,
CapsLock,
F1,
F2,
F3,
F4,
F5,
F6,
F7, -- 0x40
F8,
F9,
F10,
F11,
F12,
PScreen,
ScrollLock,
Pause,
Insert,
Home,
PgUp,
Delete,
Endd,
PgDown,
Right,
Left, -- 0x50
Down,
Up,
NumLock,
-- Keypad `/`
KpSlash,
-- Keypad `*`
KpAsterisk,
-- Keypad `-`.
KpMinus,
-- Keypad `+`.
KpPlus,
-- Keypad enter.
KpEnter,
-- Keypad 1.
Kp1,
Kp2,
Kp3,
Kp4,
Kp5,
Kp6,
Kp7,
Kp8, -- 0x60
Kp9,
Kp0,
KpDot,
-- Non-US `\` and `|` (Typically near the Left-Shift key)
NonUsBslash,
Application, -- 0x65
-- / not a key, used for errors
Power,
-- Keypad `=`.
KpEqual,
F13,
F14,
F15,
F16,
F17,
F18,
F19,
F20,
F21, -- 0x70
F22,
F23,
F24,
Execute,
Help,
Menu,
Selectt,
Stop,
Again,
Undo,
Cut,
Copy,
Paste,
Find,
Mute,
VolUp, -- 0x80
VolDown,
-- Deprecated.
LockingCapsLock,
-- Deprecated.
LockingNumLock,
-- Deprecated.
LockingScrollLock,
-- / Keypad `,`, also used for the
-- brazilian keypad period (.) key.
KpComma,
-- Used on AS/400 keyboard
KpEqualSign,
Intl1,
Intl2,
Intl3,
Intl4,
Intl5,
Intl6,
Intl7,
Intl8,
Intl9,
Lang1, -- 0x90
Lang2,
Lang3,
Lang4,
Lang5,
Lang6,
Lang7,
Lang8,
Lang9,
AltErase,
SysReq,
Cancel,
Clear,
Prior,
Returnn,
Separator,
Outt, -- 0xA0
Oper,
ClearAgain,
CrSel,
ExSel,
-- According to QMK, 0xA5-0xDF are not
-- usable on modern keyboards
-- Modifiers
-- Left Control.
LCtrl, -- = 0xE0,
-- / Left Shift.
LShift,
-- Left Alt.
LAlt,
-- Left GUI (the Windows key).
LGui,
-- Right Control.
RCtrl,
-- Right Shift.
RShift,
-- Right Alt (or Alt Gr). 
RAlt,
-- Right GUI (the Windows key).
RGui, -- 0xE7
-- Unofficial
MediaPlayPause, -- 0xE8,
MediaStopCD,
MediaPreviousSong,
MediaNextSong,
MediaEjectCD,
MediaVolUp,
MediaVolDown,
MediaMute,
MediaWWW, -- 0xF0
MediaBack,
MediaForward,
MediaStop,
MediaFind,
MediaScrollUp,
MediaScrollDown,
MediaEdit,
MediaSleep,
MediaCoffee,
MediaRefresh,
MediaCalc -- 0xFB
);
type Action_Type is (Key, No_Op, Trans, Layer, Multiple_Actions);
-- Should be a discriminated type
type Action is record
T : Action_Type; -- hould be the discriminant
C : Key_Code_T;
L : Natural;
end record;
function Kw (Code : Key_Code_T) return Action;
function Lw (V : Natural) return Action;
type Key_Modifiers is array (Natural range <>) of USB.Device.HID.Keyboard.Modifiers;
type Key_Codes_T is array (Natural range <>) of Key_Code_T;
subtype Ac is Action;
type Layout is array (0 .. Num_Layers - 1, RowR, ColR) of Action;
procedure Register_Events (L : Layout; Es : Events);
procedure Tick (L : Layout);
function Get_Key_Codes return Key_Codes_T;
function Get_Modifiers return Key_Modifiers;
procedure Init;
end Click;

29
tests/syntax-tests/source/Ada/click.gpr vendored Normal file
View File

@@ -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;