├── .gitignore ├── .hgignore ├── BUILDING.txt ├── LICENSE ├── README.md ├── alire.toml ├── bin └── .emptydir ├── dirx ├── dirx.gpr ├── dirx_build.gpr ├── dirx_examples.gpr └── src │ ├── dirx-observables.adb │ ├── dirx-observables.ads │ ├── dirx.ads │ └── examples │ ├── dirx-examples.adb │ ├── dirx-examples.ads │ ├── dirx-hash_recursive.adb │ ├── dirx-ls.adb │ └── dirx-lsr.adb ├── doc ├── .emptydir ├── Rx Design Guidelines.pdf ├── dependencies.graphml ├── dependencies.pdf ├── dispatcher.graphml ├── dispatcher.pdf ├── mergemap.graphml ├── mergemap.pdf ├── setup.graphml └── setup.pdf ├── examples ├── .gitignore ├── alire.toml ├── examples.gpr └── rxada_examples.gpr ├── lib └── .emptydir ├── obj ├── .emptydir └── lib │ └── .emptydir ├── rxada.geany ├── rxada.gpr ├── rxada_common.gpr ├── rxada_dev.gpr ├── rxada_lib.gpr ├── shippable.yml ├── src ├── body │ ├── rx-actions-typed.adb │ ├── rx-actions.adb │ ├── rx-contracts.adb │ ├── rx-debug-heavy.adb │ ├── rx-debug-observers.adb │ ├── rx-debug.adb │ ├── rx-defaults.adb │ ├── rx-dispatchers-immediate.adb │ ├── rx-dispatchers-pools.adb │ ├── rx-dispatchers-single.adb │ ├── rx-dispatchers.adb │ ├── rx-errors.adb │ ├── rx-impl-definite_observables.adb │ ├── rx-impl-definite_observers.adb │ ├── rx-impl-links.adb │ ├── rx-impl-shared_observer.adb │ ├── rx-impl-transformers.adb │ ├── rx-observables-image.adb │ ├── rx-observables.adb │ ├── rx-op-buffer.adb │ ├── rx-op-count.adb │ ├── rx-op-debounce.adb │ ├── rx-op-distinct.adb │ ├── rx-op-do_on.adb │ ├── rx-op-element_at.adb │ ├── rx-op-filter.adb │ ├── rx-op-flatmap.adb │ ├── rx-op-funnel.adb │ ├── rx-op-hold.adb │ ├── rx-op-last.adb │ ├── rx-op-length.adb │ ├── rx-op-limit.adb │ ├── rx-op-map.adb │ ├── rx-op-merge.adb │ ├── rx-op-no_op.adb │ ├── rx-op-observe_on.adb │ ├── rx-op-print.adb │ ├── rx-op-repeat.adb │ ├── rx-op-sample.adb │ ├── rx-op-scan.adb │ ├── rx-op-serialize.adb │ ├── rx-op-split.adb │ ├── rx-op-stopwatch.adb │ ├── rx-op-subscribe_on.adb │ ├── rx-op-take.adb │ ├── rx-operators.adb │ ├── rx-schedulers-pools.adb │ ├── rx-src-create.adb │ ├── rx-src-defer.adb │ ├── rx-src-empty.adb │ ├── rx-src-from.adb │ ├── rx-src-interval.adb │ ├── rx-src-just.adb │ ├── rx-src-ranges.adb │ ├── rx-src-start.adb │ ├── rx-src-timer.adb │ ├── rx-subscribe.adb │ ├── rx-subscriptions.adb │ ├── rx-tools-holders.adb │ ├── rx-tools-lazies.adb │ ├── rx-tools-semaphores.adb │ ├── rx-tools-shared_data.adb │ └── rx-traits-arrays.adb ├── bugs │ ├── b000.adb │ ├── b001_tagged.adb │ ├── b002_taskiface.adb │ ├── b003_taskleak.adb │ ├── b004_refleak.adb │ ├── finalize_leak.adb │ ├── holder_leak.adb │ ├── precedence.adb │ ├── rx-bugs-op_leak.adb │ ├── rx-bugs-support.adb │ ├── rx-bugs-support.ads │ ├── rx-bugs-testbed.adb │ └── rx-bugs.ads ├── main │ ├── rx-devel-main.adb │ ├── rx-devel.adb │ ├── rx-devel.ads │ ├── rx-devsupport.adb │ ├── rx-devsupport.ads │ ├── rx-examples-advanced.adb │ ├── rx-examples-basic.adb │ ├── rx-examples-minimal.adb │ ├── rx-examples-misc.adb │ ├── rx-examples-tests.adb │ ├── rx-examples-threading.adb │ ├── rx-examples.ads │ ├── rx-jsa2019.adb │ ├── rx-jsa2019.ads │ ├── rx-rst2017.adb │ └── rx-rst2017.ads ├── priv │ ├── rx-debug-heavy.ads │ ├── rx-debug-observers.ads │ ├── rx-debug.ads │ ├── rx-dispatchers-immediate.ads │ ├── rx-dispatchers-pools.ads │ ├── rx-dispatchers-single-lazy.ads │ ├── rx-dispatchers-single.ads │ ├── rx-dispatchers.ads │ ├── rx-impl-casts.ads │ ├── rx-impl-definite_observables.ads │ ├── rx-impl-definite_observers.ads │ ├── rx-impl-events.ads │ ├── rx-impl-holders.ads │ ├── rx-impl-links.ads │ ├── rx-impl-preservers.ads │ ├── rx-impl-shared_observer.ads │ ├── rx-impl-std.ads │ ├── rx-impl-transformers.ads │ ├── rx-impl-typed.ads │ ├── rx-impl.ads │ ├── rx-op-buffer.ads │ ├── rx-op-count.ads │ ├── rx-op-debounce.ads │ ├── rx-op-distinct.ads │ ├── rx-op-do_on.ads │ ├── rx-op-element_at.ads │ ├── rx-op-filter.ads │ ├── rx-op-flatmap.ads │ ├── rx-op-funnel.ads │ ├── rx-op-hold.ads │ ├── rx-op-last.ads │ ├── rx-op-length.ads │ ├── rx-op-limit.ads │ ├── rx-op-map.ads │ ├── rx-op-merge.ads │ ├── rx-op-no_op.ads │ ├── rx-op-observe_on.ads │ ├── rx-op-print.ads │ ├── rx-op-repeat.ads │ ├── rx-op-sample.ads │ ├── rx-op-scan.ads │ ├── rx-op-serialize.ads │ ├── rx-op-split.ads │ ├── rx-op-stopwatch.ads │ ├── rx-op-subscribe_on.ads │ ├── rx-op-take.ads │ ├── rx-op.ads │ ├── rx-src-create.ads │ ├── rx-src-defer.ads │ ├── rx-src-empty.ads │ ├── rx-src-from.ads │ ├── rx-src-interval.ads │ ├── rx-src-just.ads │ ├── rx-src-ranges.ads │ ├── rx-src-start.ads │ ├── rx-src-timer.ads │ ├── rx-src.ads │ ├── rx-tools-holders.ads │ ├── rx-tools-lazies.ads │ ├── rx-tools-semaphores.ads │ ├── rx-tools-shared_data.ads │ ├── rx-tools.ads │ ├── rx-traits-arrays.ads │ ├── rx-traits-definite_defaults.ads │ ├── rx-traits-indefinite_defaults.ads │ ├── rx-traits-iterable.ads │ └── rx-traits.ads ├── rx-actions-transform.ads ├── rx-actions-typed.ads ├── rx-actions.ads ├── rx-collections.ads ├── rx-contracts.ads ├── rx-conversions.ads ├── rx-defaults.ads ├── rx-definites.ads ├── rx-errors.ads ├── rx-factories.ads ├── rx-indefinites.ads ├── rx-numeric_observables.ads ├── rx-numeric_operators.ads ├── rx-observables-image.ads ├── rx-observables.ads ├── rx-operators.ads ├── rx-schedulers-pools.ads ├── rx-schedulers.ads ├── rx-std.ads ├── rx-subjects.ads ├── rx-subscribe.ads ├── rx-subscribers.ads ├── rx-subscriptions.ads ├── rx-traits-types.ads ├── rx-types.ads ├── rx-valueless.ads ├── rx.ads └── utests │ ├── rx-tests.adb │ └── rx-tests.ads └── trash └── bitbucket-pipelines.yml /.gitignore: -------------------------------------------------------------------------------- 1 | bin 2 | gnatinspect.* 3 | gpsauto.cgpr 4 | lib 5 | obj 6 | 7 | *-loc.xml 8 | 9 | /alire/ 10 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax: glob 2 | 3 | bin 4 | lib 5 | obj 6 | -------------------------------------------------------------------------------- /BUILDING.txt: -------------------------------------------------------------------------------- 1 | The following project files are available: 2 | 3 | rxada.gpr: 4 | to be used in client projects that do not care about having a full library linked in. 5 | 6 | rxada_lib.gpr: 7 | to be used to generate a library (and to ensure all sources are compiled, regardless of use) 8 | 9 | rxada_examples.gpr: 10 | builds demo executables 11 | 12 | rxada_dev.gpr: 13 | aggregate project that builds all sources and examples (but not the lib), to be used by the developer 14 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "rxada" 2 | description = "Experimental implementation of ReactiveX in Ada" 3 | version = "0.1.1" 4 | licenses = "LGPL-3.0-only" 5 | website = "https://github.com/mosteo/rxada" 6 | 7 | tags = ["rx", "reactive", "reactivex", "observer"] 8 | 9 | authors = ["Alejandro R. Mosteo"] 10 | maintainers = ["Alejandro R. Mosteo "] 11 | maintainers-logins = ["mosteo"] 12 | 13 | [configuration] 14 | disabled = true 15 | -------------------------------------------------------------------------------- /bin/.emptydir: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/bin/.emptydir -------------------------------------------------------------------------------- /dirx/dirx.gpr: -------------------------------------------------------------------------------- 1 | with "rxada"; 2 | 3 | project DirX is 4 | 5 | for Library_Name use "dirx"; 6 | for Library_Version use "0.0.0"; 7 | 8 | for Source_Dirs use ("src"); 9 | for Object_Dir use "obj"; 10 | for Library_Dir use "lib"; 11 | 12 | package Builder is 13 | for Switches ("ada") use ("-j0", "-g"); 14 | end Builder; 15 | 16 | package Compiler is 17 | for Switches ("ada") use ("-gnatVa", "-gnatwa", "-g", "-O2", "-gnata", "-gnato", "-fstack-check"); 18 | end Compiler; 19 | 20 | package Binder is 21 | for Switches ("ada") use ("-Es"); 22 | end Binder; 23 | 24 | end DirX; 25 | -------------------------------------------------------------------------------- /dirx/dirx_build.gpr: -------------------------------------------------------------------------------- 1 | aggregate project DirX_Build is 2 | 3 | for Project_Path use ( 4 | ".", 5 | ".." 6 | ); 7 | 8 | for Project_Files use ("dirx.gpr", 9 | "dirx_examples.gpr"); 10 | 11 | end DirX_Build; 12 | -------------------------------------------------------------------------------- /dirx/dirx_examples.gpr: -------------------------------------------------------------------------------- 1 | with "dirx"; 2 | 3 | project DirX_Examples is 4 | 5 | for Source_Dirs use ("src/examples"); 6 | for Object_Dir use "obj"; 7 | for Exec_Dir use "bin"; 8 | 9 | for Main use ("dirx-ls.adb", -- Regular ls, only files 10 | "dirx-lsr.adb", -- Recursive ls, only files 11 | "dirx-hash_recursive"); -- For 2019 special issue 12 | 13 | package Builder is 14 | for Switches ("ada") use ("-j0", "-g"); 15 | end Builder; 16 | 17 | package Compiler is 18 | for Switches ("ada") use ("-gnatVa", "-gnatwa", "-g", "-O2", "-gnata", "-gnato", "-fstack-check"); 19 | end Compiler; 20 | 21 | package Binder is 22 | for Switches ("ada") use ("-Es"); 23 | end Binder; 24 | 25 | package Linker is 26 | for Switches ("ada") use ("-g"); 27 | end Linker; 28 | 29 | end DirX_Examples; 30 | -------------------------------------------------------------------------------- /dirx/src/dirx-observables.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | with Rx.Errors; 3 | 4 | package body DirX.Observables is 5 | 6 | use RxEntries.Observables.Linkers; 7 | 8 | -- Entry_Generator type is the observable that will enumerate dir contents 9 | -- upon subscription 10 | 11 | type Entry_Generator (Path_Len : Natural) is 12 | new RxEntries.Observables.Contracts.Observable with 13 | record 14 | Path : String (1 .. Path_Len); 15 | end record; 16 | 17 | overriding procedure Subscribe 18 | (Producer : in out Entry_Generator; 19 | Consumer : in out RxEntries.Observables.Contracts.Observer'Class); 20 | 21 | ----------------------- 22 | -- Directory_Entries -- 23 | ----------------------- 24 | 25 | function Directory_Entries 26 | (Directory : Path; 27 | Recursive : Boolean) 28 | return Entry_Observable 29 | is 30 | (Entry_Generator'(Path_Len => Directory'Length, 31 | Path => Directory) 32 | & (if Recursive 33 | then RxEntries.Observables.Expand (Observe'Access) 34 | else RxEntries.Observables.No_Op)); 35 | 36 | ------------- 37 | -- Observe -- 38 | ------------- 39 | 40 | function Observe (This : Directory_Entry) return Entry_Observable is 41 | (if This.Is_Directory and then 42 | AD.Simple_Name (This.Get_Entry) /= "." and then 43 | AD.Simple_Name (This.Get_Entry) /= ".." 44 | then Directory_Entries (AD.Full_Name (This.Get_Entry), 45 | Recursive => False) 46 | else RxEntries.Observables.Empty); 47 | 48 | --------------- 49 | -- Subscribe -- 50 | --------------- 51 | 52 | overriding procedure Subscribe 53 | (Producer : in out Entry_Generator; 54 | Consumer : in out RxEntries.Observables.Contracts.Observer'Class) 55 | is 56 | Search : AD.Search_Type; 57 | begin 58 | AD.Start_Search (Search => Search, 59 | Pattern => "*", 60 | Directory => Producer.Path); 61 | 62 | while AD.More_Entries (Search) loop 63 | declare 64 | DE : constant Entry_Access := new AD.Directory_Entry_Type; 65 | Item : constant Directory_Entry := Wrap (DE); 66 | begin 67 | AD.Get_Next_Entry (Search, DE.all); 68 | Rx.Debug.Trace ("dir_entry on_next"); 69 | Consumer.On_Next (Item); 70 | end; 71 | end loop; 72 | 73 | AD.End_Search (Search); 74 | Rx.Debug.Trace ("dir_entry on_complete"); 75 | Consumer.On_Complete; 76 | exception 77 | when E : others => 78 | AD.End_Search (Search); 79 | Rx.Debug.Trace ("dir_entry on_error"); 80 | Consumer.On_Error (Rx.Errors.Create (E)); 81 | end Subscribe; 82 | 83 | end DirX.Observables; 84 | -------------------------------------------------------------------------------- /dirx/src/dirx-observables.ads: -------------------------------------------------------------------------------- 1 | with Rx.Indefinites; 2 | 3 | package DirX.Observables is 4 | 5 | package RxEntries is new Rx.Indefinites (DirX.Directory_Entry); 6 | 7 | subtype Entry_Observable is RxEntries.Observable; 8 | 9 | function Directory_Entries 10 | (Directory : Path; 11 | Recursive : Boolean) 12 | return Entry_Observable; 13 | -- Enumerate entries in a given path. 14 | -- Optionally, enter into found directories and emit their contents too 15 | 16 | function Observe (This : Directory_Entry) return Entry_Observable; 17 | -- For use in Flat_Map: turns a directory entry into an observable. 18 | -- If entry is Directory, it emits all its *immediate* children 19 | -- Otherwise, nothing is emitted 20 | 21 | -- TODO: filters for file kind, file pattern, but do it in DirX root 22 | 23 | end DirX.Observables; 24 | -------------------------------------------------------------------------------- /dirx/src/dirx.ads: -------------------------------------------------------------------------------- 1 | with Ada.Directories; 2 | 3 | with Rx.Std; 4 | 5 | private with Rx.Tools.Shared_Data; 6 | 7 | package DirX is 8 | 9 | ----------- 10 | -- Types -- 11 | ----------- 12 | 13 | subtype Path is String; 14 | -- A Path can be either a folder, file, subpath, combination of those, etc. 15 | 16 | subtype Path_Observable is Rx.Std.Strings.Observable; 17 | 18 | type Name_Kinds is (Full_Name, Simple_Name); 19 | 20 | ----------------------- 21 | -- Directory entries -- 22 | ----------------------- 23 | 24 | -- We need a nonlimited type to be able to use it with Rx, so this one 25 | -- encapsulates entries in Ada.Directories 26 | 27 | type Directory_Entry (<>) is tagged private; 28 | 29 | type Entry_Reference 30 | (The_Entry : access constant Ada.Directories.Directory_Entry_Type) 31 | is limited null record 32 | with Implicit_Dereference => The_Entry; 33 | 34 | function Get_Entry (This : Directory_Entry) return Entry_Reference; 35 | 36 | function Is_Directory (This : Directory_Entry) return Boolean; 37 | 38 | private 39 | 40 | package AD renames Ada.Directories; 41 | 42 | use all type AD.File_Kind; 43 | 44 | type Entry_Access is access AD.Directory_Entry_Type; 45 | 46 | package Shared_Entries is new Rx.Tools.Shared_Data (AD.Directory_Entry_Type, 47 | Entry_Access); 48 | 49 | type Directory_Entry is new Shared_Entries.Proxy with null record; 50 | 51 | --------------- 52 | -- Get_Entry -- 53 | --------------- 54 | 55 | function Get_Entry (This : Directory_Entry) return Entry_Reference is 56 | (Entry_Reference'(The_Entry => Shared_Entries.Proxy (This).Get.Actual)); 57 | 58 | ------------------ 59 | -- Is_Directory -- 60 | ------------------ 61 | 62 | function Is_Directory (This : Directory_Entry) return Boolean is 63 | (AD.Kind (This.Get_Entry) = AD.Directory); 64 | 65 | end DirX; 66 | -------------------------------------------------------------------------------- /dirx/src/examples/dirx-examples.adb: -------------------------------------------------------------------------------- 1 | with Ada.Streams.Stream_IO; 2 | with Ada.Text_IO; 3 | 4 | package body DirX.Examples is 5 | 6 | ---------- 7 | -- Hash -- 8 | ---------- 9 | 10 | function Hash (Filename : String) return GNAT.SHA512.Message_Digest is 11 | File : Ada.Streams.Stream_IO.File_Type; 12 | Buffer : Ada.Streams.Stream_Element_Array (1 .. 1048576); 13 | Last : Ada.Streams.Stream_Element_Offset; 14 | Ctxt : aliased GNAT.SHA512.Context; 15 | Hasher : GNAT.SHA512.Hash_Stream (Ctxt'Access); 16 | 17 | use Ada.Streams.Stream_IO; 18 | begin 19 | Open (File, Mode => In_File, Name => Filename); 20 | 21 | while not End_Of_File (File) loop 22 | Read (File, Buffer, Last); 23 | Hasher.Write (Buffer (1 .. Last)); 24 | end loop; 25 | 26 | Close (File); 27 | 28 | return GNAT.SHA512.Digest (Ctxt); 29 | end Hash; 30 | 31 | ---------- 32 | -- Hash -- 33 | ---------- 34 | 35 | function Hash (This : DirX.Directory_Entry) return Hashed_Entry is 36 | 37 | 38 | use Ada.Directories; 39 | 40 | Filename : constant String := Full_Name (This.Get_Entry); 41 | begin 42 | if Kind (Filename) = Directory then 43 | return Hashed_Entry'(Name_Len => Filename'Length, 44 | Is_File => False, 45 | Name => Filename); 46 | else 47 | return Hashed_Entry'(Name_Len => Filename'Length, 48 | Is_File => True, 49 | Name => Filename, 50 | Hash => Hash (Filename)); 51 | end if; 52 | end Hash; 53 | 54 | ---------------- 55 | -- Print_Hash -- 56 | ---------------- 57 | 58 | procedure Print_Hash (This : Hashed_Entry) is 59 | use Ada.Text_IO; 60 | begin 61 | if This.Is_File then 62 | Put_Line (This.Hash & " " & This.Name); 63 | else 64 | Put_Line (GNAT.SHA512.Message_Digest'(others => ' ') & " " & This.Name); 65 | end if; 66 | end Print_Hash; 67 | 68 | end DirX.Examples; 69 | -------------------------------------------------------------------------------- /dirx/src/examples/dirx-examples.ads: -------------------------------------------------------------------------------- 1 | with GNAT.SHA512; 2 | 3 | with DirX.Observables; 4 | 5 | with Rx.Indefinites; 6 | with Rx.Operators; 7 | 8 | package DirX.Examples is 9 | 10 | -- Types to store a hash with a filename and use it with Rx 11 | 12 | type Hashed_Entry (Name_Len : Positive; Is_File : Boolean) is record 13 | Name : String (1 .. Name_Len); 14 | 15 | case Is_File is 16 | when True => Hash : GNAT.SHA512.Message_Digest; 17 | when False => null; 18 | end case; 19 | end record; 20 | 21 | package RxHashed is new Rx.Indefinites (Hashed_Entry); 22 | 23 | package Entry_To_Hash is new Rx.Operators 24 | (DirX.Observables.RxEntries.Observables, 25 | RxHashed.Observables); 26 | 27 | ----------------- 28 | -- Subprograms -- 29 | ----------------- 30 | 31 | function Hash (This : DirX.Directory_Entry) return Hashed_Entry; 32 | 33 | procedure Print_Hash (This : Hashed_Entry); 34 | 35 | end DirX.Examples; 36 | -------------------------------------------------------------------------------- /dirx/src/examples/dirx-hash_recursive.adb: -------------------------------------------------------------------------------- 1 | with Ada.Command_Line; 2 | with Ada.Text_IO; use Ada.Text_IO; 3 | 4 | with DirX.Examples; 5 | with DirX.Observables; 6 | 7 | with Rx.Schedulers; 8 | with Rx.Subscriptions; 9 | 10 | with System.Multiprocessors; 11 | 12 | procedure DirX.Hash_Recursive is 13 | use Ada.Command_Line; 14 | 15 | use Observables; 16 | use Observables.RxEntries.Observables; 17 | use Examples.RxHashed.Observables; 18 | use Examples.Entry_To_Hash; 19 | 20 | Target : constant Path := (if Argument_Count = 0 21 | then "." 22 | else Argument (1)); 23 | 24 | Context : String (1 .. 3) := "1-1"; 25 | 26 | ------------- 27 | -- Inspect -- 28 | ------------- 29 | 30 | procedure Inspect (Kind : Rx.Rx_Event_Kinds; 31 | Since_Previous : Duration; 32 | Since_Subscription : Duration) 33 | is 34 | pragma Unreferenced (Since_Previous); 35 | use all type Rx.Rx_Event_Kinds; 36 | begin 37 | if Kind = On_Complete then 38 | New_Line; 39 | Put_Line ("Wall time [" & Context & "]:" & Since_Subscription'Img); 40 | else 41 | null; 42 | -- Put_Line ("Incr time [" & Context & "]:" & Since_Previous'Img); 43 | end if; 44 | end Inspect; 45 | 46 | Sub : Rx.Subscriptions.Subscription; 47 | begin 48 | Put_Line ("Number of CPUs:" & System.Multiprocessors.Number_Of_CPUs'Img); 49 | 50 | -- Sequential listing & hashing of files, with printing 51 | Sub := 52 | Directory_Entries (Target, Recursive => True) 53 | & Examples.Hash'Access 54 | & Subscribe (On_Next => Examples.Print_Hash'Access); 55 | 56 | -- Sequential timing 57 | Sub := 58 | Directory_Entries (Target, Recursive => True) 59 | & Examples.Hash'Access 60 | & Stopwatch (Inspect'Unrestricted_Access) 61 | & Subscribe; 62 | 63 | -- Parallel hashing timing 64 | Context := "1-N"; 65 | Sub := 66 | Directory_Entries (Target, Recursive => True) 67 | & Flat_Map (Observe_On (Rx.Schedulers.Computation) 68 | & Examples.Hash'Access) 69 | & Stopwatch (Inspect'Unrestricted_Access) 70 | & Subscribe; 71 | 72 | while Sub.Is_Subscribed loop 73 | delay 0.1; 74 | end loop; 75 | 76 | -- Parallel enumeration and hashing 77 | Context := "M-N"; 78 | Sub := 79 | Directory_Entries (Target, Recursive => False) 80 | & Expand (Observe_On (Rx.Schedulers.IO) 81 | & Dirx.Observables.Observe'Access) 82 | & Flat_Map (Observe_On (Rx.Schedulers.Computation) 83 | & Examples.Hash'Access) 84 | & Stopwatch (Inspect'Unrestricted_Access) 85 | & Subscribe; -- (On_Next => Examples.Print_Hash'Access); 86 | 87 | while Sub.Is_Subscribed loop 88 | delay 0.1; 89 | end loop; 90 | 91 | end DirX.Hash_Recursive; 92 | -------------------------------------------------------------------------------- /dirx/src/examples/dirx-ls.adb: -------------------------------------------------------------------------------- 1 | with Ada.Command_Line; 2 | with Ada.Directories; 3 | with Ada.Text_IO; 4 | 5 | with DirX.Observables; 6 | 7 | -- with Rx.Std; use Rx.Std; 8 | 9 | procedure DirX.Ls is 10 | use Ada.Command_Line; 11 | 12 | --------------------- 13 | -- Print_Full_Name -- 14 | --------------------- 15 | 16 | procedure Print_Full_Name (This : DirX.Directory_Entry) is 17 | begin 18 | Ada.Text_IO.Put_Line (Ada.Directories.Full_Name (This.Get_Entry)); 19 | end Print_Full_Name; 20 | 21 | Target : constant Path := (if Argument_Count = 0 22 | then "." 23 | else Argument (1)); 24 | begin 25 | -- Ordinary listing of entries in given folder 26 | DirX.Observables.RxEntries.Observables.For_Each 27 | (DirX.Observables.Directory_Entries (Target, Recursive => False), 28 | On_Next => Print_Full_Name'Unrestricted_Access); 29 | 30 | end DirX.Ls; 31 | -------------------------------------------------------------------------------- /dirx/src/examples/dirx-lsr.adb: -------------------------------------------------------------------------------- 1 | with Ada.Command_Line; 2 | with Ada.Directories; 3 | with Ada.Text_IO; 4 | 5 | with DirX.Observables; 6 | 7 | -- with Rx.Std; use Rx.Std; 8 | 9 | procedure DirX.Lsr is 10 | use Ada.Command_Line; 11 | 12 | --------------------- 13 | -- Print_Full_Name -- 14 | --------------------- 15 | 16 | procedure Print_Full_Name (This : DirX.Directory_Entry) is 17 | begin 18 | Ada.Text_IO.Put_Line (Ada.Directories.Full_Name (This.Get_Entry)); 19 | end Print_Full_Name; 20 | 21 | Target : constant Path := (if Argument_Count = 0 22 | then "." 23 | else Argument (1)); 24 | begin 25 | -- Recursive listing of files 26 | DirX.Observables.RxEntries.Observables.For_Each 27 | (DirX.Observables.Directory_Entries (Target, Recursive => True), 28 | On_Next => Print_Full_Name'Unrestricted_Access); 29 | 30 | end DirX.Lsr; 31 | -------------------------------------------------------------------------------- /doc/.emptydir: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/.emptydir -------------------------------------------------------------------------------- /doc/Rx Design Guidelines.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/Rx Design Guidelines.pdf -------------------------------------------------------------------------------- /doc/dependencies.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/dependencies.pdf -------------------------------------------------------------------------------- /doc/dispatcher.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/dispatcher.pdf -------------------------------------------------------------------------------- /doc/mergemap.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/mergemap.pdf -------------------------------------------------------------------------------- /doc/setup.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/doc/setup.pdf -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | /obj/ 2 | /bin/ 3 | /alire/ 4 | /config/ 5 | -------------------------------------------------------------------------------- /examples/alire.toml: -------------------------------------------------------------------------------- 1 | name = "examples" 2 | description = "Examples of using RxAda" 3 | version = "0.1.0" 4 | 5 | authors = ["Alejandro R. Mosteo"] 6 | maintainers = ["Alejandro R. Mosteo "] 7 | maintainers-logins = ["mosteo"] 8 | licenses = "MIT OR Apache-2.0 WITH LLVM-exception" 9 | website = "" 10 | tags = [] 11 | 12 | executables = [ 13 | "rx-devel-main", 14 | "rx-examples-advanced", 15 | "rx-examples-basic", 16 | "rx-examples-minimal", 17 | "rx-examples-misc", 18 | "rx-examples-tests", 19 | "rx-examples-threading" 20 | ] 21 | project-files = ["rxada_examples.gpr"] 22 | 23 | [[depends-on]] 24 | rxada = "~0.1.1" 25 | 26 | [[pins]] 27 | rxada = { path='..' } 28 | -------------------------------------------------------------------------------- /examples/examples.gpr: -------------------------------------------------------------------------------- 1 | with "config/examples_config.gpr"; 2 | project Examples is 3 | 4 | for Source_Dirs use ("src/", "config/"); 5 | for Object_Dir use "obj/" & Examples_Config.Build_Profile; 6 | for Create_Missing_Dirs use "True"; 7 | for Exec_Dir use "bin"; 8 | for Main use ("examples.adb"); 9 | 10 | package Compiler is 11 | for Default_Switches ("Ada") use Examples_Config.Ada_Compiler_Switches; 12 | end Compiler; 13 | 14 | package Binder is 15 | for Switches ("Ada") use ("-Es"); -- Symbolic traceback 16 | end Binder; 17 | 18 | package Install is 19 | for Artifacts (".") use ("share"); 20 | end Install; 21 | 22 | end Examples; 23 | -------------------------------------------------------------------------------- /examples/rxada_examples.gpr: -------------------------------------------------------------------------------- 1 | with "rxada"; 2 | 3 | project RxAda_Examples is 4 | 5 | for Source_Dirs use ("../src/bugs", 6 | "../src/main"); 7 | 8 | for Object_Dir use "obj"; 9 | for Exec_Dir use "bin"; 10 | 11 | for Main use ("rx-devel-main.adb", 12 | "rx-examples-tests.adb", 13 | "rx-examples-minimal.adb", 14 | "rx-examples-misc.adb", 15 | "rx-examples-basic.adb", 16 | "rx-examples-advanced.adb", 17 | "rx-examples-threading.adb"); 18 | 19 | package Builder renames RxAda.Builder; 20 | 21 | package Compiler renames RxAda.Compiler; 22 | 23 | package Binder renames RxAda.Binder; 24 | 25 | end RxAda_Examples; 26 | -------------------------------------------------------------------------------- /lib/.emptydir: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/lib/.emptydir -------------------------------------------------------------------------------- /obj/.emptydir: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/obj/.emptydir -------------------------------------------------------------------------------- /obj/lib/.emptydir: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mosteo/rxada/4824ae7596364ccca88f0081fc9c5618d9fe4778/obj/lib/.emptydir -------------------------------------------------------------------------------- /rxada.geany: -------------------------------------------------------------------------------- 1 | [editor] 2 | line_wrapping=false 3 | line_break_column=79 4 | auto_continue_multiline=true 5 | 6 | [file_prefs] 7 | final_new_line=true 8 | ensure_convert_new_lines=false 9 | strip_trailing_spaces=false 10 | replace_tabs=false 11 | 12 | [indentation] 13 | indent_width=3 14 | indent_type=0 15 | indent_hard_tab_width=8 16 | detect_indent=false 17 | detect_indent_width=true 18 | indent_mode=2 19 | 20 | [project] 21 | name=RxAda 22 | base_path=./ 23 | description= 24 | file_patterns=*.ads;*.adb; 25 | 26 | [long line marker] 27 | long_line_behaviour=1 28 | long_line_column=72 29 | 30 | [files] 31 | current_page=0 32 | FILE_NAME_0=2461;Pascal;0;EUTF-8;0;1;0;%2Fmedia%2Fjano%2F7C9B-6206%2FLa%20mazmorra%20de%20Antonio%2FMuestraProfesorCorregido.pas;0;8 33 | FILE_NAME_1=3006;Pascal;0;EISO-8859-1;0;1;0;%2Fhome%2Fjano%2Flocal%2Ffundinf%2Fproyectos%2Frpg%2Frpglib.pas;0;3 34 | 35 | [VTE] 36 | last_dir=/home/jano 37 | 38 | [build-menu] 39 | AdaFT_01_LB=_Build 40 | AdaFT_01_CM=gprbuild 41 | AdaFT_01_WD=%p 42 | filetypes=Ada;Pascal; 43 | AdaFT_00_LB=_Compile 44 | AdaFT_00_CM=gprbuild -c "%d/%f" 45 | AdaFT_00_WD=%p 46 | PascalFT_00_LB=_Compile 47 | PascalFT_00_CM=fpc -gl "%f" 48 | PascalFT_00_WD= 49 | -------------------------------------------------------------------------------- /rxada.gpr: -------------------------------------------------------------------------------- 1 | with "rxada_common"; 2 | 3 | project RxAda is 4 | 5 | for Source_Dirs use ("src/**"); 6 | for Excluded_Source_Dirs use ("src/bugs", 7 | "src/main"); 8 | 9 | for Object_Dir use "obj"; 10 | 11 | package Ide renames RxAda_Common.Ide; 12 | 13 | package Builder renames RxAda_Common.Builder; 14 | 15 | package Compiler renames RxAda_Common.Compiler; 16 | 17 | package Binder renames RxAda_Common.Binder; 18 | 19 | package Gnattest renames RxAda_Common.Gnattest; 20 | 21 | end RxAda; 22 | -------------------------------------------------------------------------------- /rxada_common.gpr: -------------------------------------------------------------------------------- 1 | abstract project RxAda_Common is 2 | 3 | type Build_Type is ("debug", "release"); 4 | Build : Build_Type := external ("build", "debug"); 5 | 6 | package Ide is 7 | for Vcs_Kind use "git"; 8 | for Documentation_Dir use "doc/"; 9 | end Ide; 10 | 11 | package Builder is 12 | case Build is 13 | when "debug" => 14 | for Default_Switches ("ada") use ("-j0", "-s", "-g"); 15 | when "release" => 16 | for Default_Switches ("ada") use ("-j0", "-s"); 17 | end case; 18 | end Builder; 19 | 20 | package Compiler is 21 | case Build is 22 | when "debug" => 23 | for Default_Switches ("ada") use ("-gnatwal.f", 24 | "-gnatVd", -- use Va for even more checks 25 | 26 | "-g", "-Og", 27 | "-gnato", "-fstack-check", "-gnata", 28 | "-gnatf", "-gnat12", 29 | 30 | "-gnatyO"); 31 | when "release" => 32 | for Default_Switches ("ada") use ("-O3", "-gnatn", "-gnat12"); 33 | end case; 34 | end Compiler; 35 | 36 | package Binder is 37 | case Build is 38 | when "debug" => 39 | for Default_Switches ("ada") use ("-E", "-Es"); 40 | when "release" => 41 | null; 42 | end case; 43 | end Binder; 44 | 45 | package Gnattest is 46 | for Tests_Dir use "../aunit"; 47 | for Stubs_Default use "pass"; 48 | end Gnattest; 49 | 50 | end RxAda_Common; 51 | -------------------------------------------------------------------------------- /rxada_dev.gpr: -------------------------------------------------------------------------------- 1 | aggregate project RxAda_Dev is 2 | 3 | for Project_Files use ("rxada.gpr", 4 | "rxada_examples.gpr"); 5 | -- Lib is not compiled here because it would double compilation times 6 | -- Those needing a library can use that project 7 | -- The effect of full compilation even if not linked in is achieved with rxada.gpr without main files 8 | 9 | end RxAda_Dev; 10 | -------------------------------------------------------------------------------- /rxada_lib.gpr: -------------------------------------------------------------------------------- 1 | library project RxAda_Lib extends "rxada.gpr" is 2 | 3 | for Library_Name use "rxada"; 4 | for Library_Dir use "lib"; 5 | for Object_Dir use "obj/lib"; 6 | 7 | end RxAda_Lib; 8 | -------------------------------------------------------------------------------- /shippable.yml: -------------------------------------------------------------------------------- 1 | language: none # Ada 2 | 3 | branches: 4 | only: 5 | - master 6 | - testing 7 | 8 | env: 9 | - IMAGE_TAG="ubuntu-lts" 10 | - IMAGE_TAG="debian-testing" 11 | - IMAGE_TAG="community-2018" 12 | 13 | build: 14 | pre_ci_boot: 15 | image_name: alire/gnat 16 | image_tag: $IMAGE_TAG 17 | pull: true 18 | ci: 19 | - apt-get update 20 | - apt-get install -y valgrind 21 | - gprbuild -j0 -p -P rxada_dev.gpr 22 | - valgrind --error-exitcode=1 bin/rx-examples-tests 23 | -------------------------------------------------------------------------------- /src/body/rx-actions-typed.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Actions.Typed is 2 | 3 | type Countdown_Filter is new TFilter1 with record 4 | Remaining : Rx_Natural; 5 | end record; 6 | 7 | overriding function Check (Filter : in out Countdown_Filter; V : T) return Boolean; 8 | 9 | --------------- 10 | -- Countdown -- 11 | --------------- 12 | 13 | function Countdown (Times : Rx_Natural) return TFilter1'Class is (Countdown_Filter'(Remaining => Times)); 14 | 15 | ----------- 16 | -- Check -- 17 | ----------- 18 | 19 | overriding function Check (Filter : in out Countdown_Filter; V : T) return Boolean is 20 | pragma Unreferenced (V); 21 | begin 22 | return Passed : constant Boolean := Filter.Remaining > 0 do 23 | if Passed then 24 | Filter.Remaining := Filter.Remaining - 1; 25 | end if; 26 | end return; 27 | end Check; 28 | 29 | ----------- 30 | -- "not" -- 31 | ----------- 32 | 33 | type Negator is new TFilter1 with record 34 | Filter : HTFilter1; 35 | end record; 36 | 37 | ----------- 38 | -- Check -- 39 | ----------- 40 | 41 | overriding function Check (This : in out Negator; V : T) return Boolean is 42 | begin 43 | return not This.Filter.Ref.Check (V); 44 | end Check; 45 | 46 | function "not" (Filter : TFilter1'Class) return TFilter1'Class is 47 | (Negator'(Filter => + Filter)); 48 | 49 | -- These can't be expression functions because of gnat bug 50 | 51 | --------------- 52 | -- WTFunc0 -- 53 | --------------- 54 | 55 | type WTFunc0 (Func : Func0) is new TFunc0 with null record; 56 | overriding function Get (Func : in out WTFunc0) return T is (Func.Func.all); 57 | 58 | function Wrap (Func : Func0) return TFunc0'Class is 59 | begin 60 | return WTFunc0'(Func => Func); 61 | end Wrap; 62 | 63 | ------------------- 64 | -- WTFunc1Str --- 65 | ------------------- 66 | 67 | type WTFunc1Str (Func : Func1Str) is new TFunc1Str with null record; 68 | overriding function Convert (Func : in out WTFunc1Str; V : T) return String is (Func.Func (V)); 69 | function Wrap (Func : Func1Str) return TFunc1Str'Class is 70 | begin 71 | return WTFunc1Str'(Func => Func); 72 | end Wrap; 73 | 74 | ----------------- 75 | -- WTFilter1 -- 76 | ----------------- 77 | 78 | type WTFilter1 (Filter : Filter1) is new TFilter1 with null record; 79 | overriding function Check (Filter : in out WTFilter1; V : T) return Boolean is (Filter.Filter (V)); 80 | function Wrap (Filter : Filter1) return TFilter1'Class is 81 | begin 82 | return WTFilter1'(Filter => Filter); 83 | end Wrap; 84 | 85 | ------------- 86 | -- WTProc1 -- 87 | ------------- 88 | 89 | type WTProc1 (Proc : Proc1) is new TProc1 with null record; 90 | overriding procedure Call (Proc : in out WTProc1; V : T) is 91 | begin 92 | Proc.Proc (V); 93 | end Call; 94 | function Wrap (Proc : Proc1) return TProc1'Class is 95 | (WTProc1'(Proc => Proc)); 96 | 97 | end Rx.Actions.Typed; 98 | -------------------------------------------------------------------------------- /src/body/rx-actions.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Actions is 2 | 3 | --------------- 4 | -- WTProc0 -- 5 | --------------- 6 | 7 | type WTProc0 (Proc : Proc0) is new TProc0 with null record; 8 | overriding procedure Run (Proc : in out WTProc0) is 9 | begin 10 | Proc.Proc.all; 11 | end Run; 12 | function Wrap (Proc : Proc0) return TProc0'Class is (WTProc0'(Proc => Proc)); 13 | 14 | --------------- 15 | -- WTFilter0 -- 16 | --------------- 17 | 18 | type WTFilter0 (Filter : Filter0) is new TFilter0 with null record; 19 | overriding function Check (Filter : in out WTFilter0) return Boolean is 20 | begin 21 | return Filter.Filter.all; 22 | end Check; -- Cannot be expression function because of GNAT bug 23 | function Wrap (Check : Filter0) return TFilter0'Class is (WTFilter0'(Filter => Check)); 24 | 25 | ------------- 26 | -- Counter -- 27 | ------------- 28 | 29 | type Counter (Times : Positive) is new TFilter0 with record 30 | Current : Natural := 0; 31 | end record; 32 | 33 | overriding function Check (This : in out Counter) return Boolean is 34 | begin 35 | This.Current := This.Current + 1; 36 | return This.Current >= This.Times; 37 | end Check; 38 | 39 | function Count (Times : Positive) return TFilter0'Class is 40 | (Counter'(Times => Times, 41 | others => <>)); 42 | 43 | ----------- 44 | -- "not" -- 45 | ----------- 46 | 47 | type Negator is new TFilter0 with record 48 | Filter : HTFilter0; 49 | end record; 50 | 51 | ----------- 52 | -- Check -- 53 | ----------- 54 | 55 | overriding function Check (This : in out Negator) return Boolean is 56 | begin 57 | return not This.Filter.Ref.Check; 58 | end Check; 59 | 60 | function "not" (Filter : TFilter0'Class) return TFilter0'Class is 61 | (Negator'(Filter => + Filter)); 62 | 63 | end Rx.Actions; 64 | -------------------------------------------------------------------------------- /src/body/rx-contracts.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Contracts is 2 | 3 | ----------------- 4 | -- On_Complete -- 5 | ----------------- 6 | 7 | overriding procedure On_Complete (This : in out Sink) is 8 | begin 9 | This.Subscription.Unsubscribe; 10 | end On_Complete; 11 | 12 | ---------------------- 13 | -- Set_Subscription -- 14 | ---------------------- 15 | 16 | procedure Set_Subscription (This : in out Sink; S : Subscriptions.Subscription) is 17 | begin 18 | This.Subscription := S; 19 | end Set_Subscription; 20 | 21 | --------------- 22 | -- Subscribe -- 23 | --------------- 24 | 25 | function Subscribe 26 | (Producer : Observable'Class; 27 | Consumer : Sink'Class) 28 | return Subscriptions.Subscription 29 | is 30 | Actual_L : Observable'Class := Producer; 31 | Actual_R : Sink'Class := Consumer; 32 | -- We create copies to start chain instantiation with fresh links 33 | Sub : constant Subscriptions.Subscription := Subscriptions.Subscribe; 34 | begin 35 | Actual_R.Set_Subscription (Sub); 36 | Actual_L.Subscribe (Actual_R); 37 | return Sub; 38 | end Subscribe; 39 | 40 | ----------------- 41 | -- Unsubscribe -- 42 | ----------------- 43 | 44 | overriding procedure Unsubscribe (This : in out Sink) is 45 | begin 46 | This.Subscription.Unsubscribe; 47 | end Unsubscribe; 48 | 49 | end Rx.Contracts; 50 | -------------------------------------------------------------------------------- /src/body/rx-debug-heavy.adb: -------------------------------------------------------------------------------- 1 | with GNAT.OS_Lib; 2 | with GNAT.Traceback.Symbolic; 3 | 4 | package body Rx.Debug.Heavy is 5 | 6 | ---------- 7 | -- Dump -- 8 | ---------- 9 | 10 | procedure Dump is 11 | begin 12 | Gnat.Debug_Pools.Print_Info_Stdout (Debug_Pool, Display_Leaks => True); 13 | Gnat.Debug_Pools.Dump_Gnatmem (Debug_Pool, "gmem.out"); 14 | end Dump; 15 | 16 | 17 | --------------- 18 | -- Backtrace -- 19 | --------------- 20 | 21 | procedure Backtrace (E : Ada.Exceptions.Exception_Occurrence) is 22 | begin 23 | Debug.Print (E); 24 | Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E)); 25 | end Backtrace; 26 | 27 | ----------------------- 28 | -- Current_Backtrace -- 29 | ----------------------- 30 | 31 | procedure Current_Backtrace (Bailout : Boolean := False; 32 | Exit_Code : Integer := 1) 33 | is 34 | Max : constant := 20; 35 | Used : Natural; 36 | Calls : GNAT.Traceback.Tracebacks_Array (1 .. Max); 37 | begin 38 | GNAT.Traceback.Call_Chain (Calls, Used); 39 | 40 | Put_Line (Gnat.Traceback.Symbolic.Symbolic_Traceback (Calls (1 .. Used))); 41 | if Bailout then 42 | GNAT.OS_Lib.OS_Exit (Exit_Code); 43 | end if; 44 | end Current_Backtrace; 45 | 46 | end Rx.Debug.Heavy; 47 | -------------------------------------------------------------------------------- /src/body/rx-defaults.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Defaults is 4 | 5 | --------------------------- 6 | -- Default_Error_Handler -- 7 | --------------------------- 8 | 9 | procedure Default_Error_Handler 10 | (This : in out Contracts.Observer'Class; 11 | Except : Ada.Exceptions.Exception_Occurrence) 12 | is 13 | use Ada.Exceptions; 14 | begin 15 | if Exception_Identity (Except) = Unimplemented'Identity or else 16 | Exception_Identity (Except) = Program_Error'Identity or else 17 | Exception_Identity (Except) = Storage_Error'Identity 18 | then 19 | Reraise_Occurrence (Except); 20 | -- Those are normally not regular exceptions to be dealt by clients 21 | else 22 | begin 23 | This.On_Error (Errors.Create (Except)); 24 | exception 25 | when E : No_Longer_Subscribed => 26 | Debug.Report (E, "On_Error rejected during error handling:", Debug.Impl, Reraise => False); 27 | when E : others => 28 | Debug.Report (E, "Exception during error handling:", Debug.Warn, Reraise => True); 29 | end; 30 | end if; 31 | end Default_Error_Handler; 32 | 33 | ---------------------- 34 | -- Default_On_Error -- 35 | ---------------------- 36 | 37 | procedure Default_On_Error (E : Errors.Occurrence) is 38 | begin 39 | Debug.Trace ("defaults [on_error]"); 40 | Debug.Report (E.Get_Exception.all, "Unhandled error", Debug.Warn); 41 | raise Program_Error with "unhandled error"; 42 | end Default_On_Error; 43 | 44 | -------------- 45 | -- On_Error -- 46 | -------------- 47 | 48 | overriding procedure On_Error (This : in out Observer; 49 | E : Errors.Occurrence) 50 | is 51 | pragma Unreferenced (This); 52 | begin 53 | Default_On_Error (E); 54 | end On_Error; 55 | 56 | end Rx.Defaults; 57 | -------------------------------------------------------------------------------- /src/body/rx-dispatchers-immediate.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Dispatchers.Immediate is 2 | 3 | -------------- 4 | -- Schedule -- 5 | -------------- 6 | 7 | overriding procedure Schedule 8 | (Where : in out Dispatcher; 9 | What : Runnable'Class; 10 | Time : Ada.Calendar.Time := Ada.Calendar.Clock) 11 | is 12 | pragma Unreferenced (Where); 13 | begin 14 | if Time > Ada.Calendar.Clock then 15 | raise Constraint_Error with "Future scheduling in immediate scheduler not allowed"; 16 | end if; 17 | What.Run; 18 | end Schedule; 19 | 20 | end Rx.Dispatchers.Immediate; 21 | -------------------------------------------------------------------------------- /src/body/rx-errors.adb: -------------------------------------------------------------------------------- 1 | with Ada.Unchecked_Deallocation; 2 | 3 | package body Rx.Errors is 4 | 5 | ------------ 6 | -- Create -- 7 | ------------ 8 | 9 | function Create (From : Ada.Exceptions.Exception_Occurrence) return Occurrence is 10 | begin 11 | return E : Occurrence do 12 | Fill (E, From); 13 | end return; 14 | end Create; 15 | 16 | ---------- 17 | -- Fill -- 18 | ---------- 19 | 20 | procedure Fill 21 | (Error : out Occurrence; 22 | From : Ada.Exceptions.Exception_Occurrence) 23 | is 24 | begin 25 | if Error.Instance = null then 26 | Error.Instance := new Ada.Exceptions.Exception_Occurrence; 27 | end if; 28 | Ada.Exceptions.Save_Occurrence (Error.Instance.all, From); 29 | end Fill; 30 | 31 | ------------- 32 | -- Reraise -- 33 | ------------- 34 | 35 | procedure Reraise (Error : Occurrence) is 36 | begin 37 | Ada.Exceptions.Reraise_Occurrence (Error.Instance.all); 38 | end Reraise; 39 | 40 | -------------- 41 | -- Finalize -- 42 | -------------- 43 | 44 | overriding procedure Finalize (E : in out Occurrence) is 45 | procedure Free is new Ada.Unchecked_Deallocation (Ada.Exceptions.Exception_Occurrence, Except_Access); 46 | begin 47 | Free (E.Instance); 48 | end Finalize; 49 | 50 | ------------ 51 | -- Adjust -- 52 | ------------ 53 | 54 | overriding procedure Adjust (E : in out Occurrence) is 55 | Mine : Except_Access; 56 | begin 57 | if E.Instance /= null then 58 | Mine := new Ada.Exceptions.Exception_Occurrence; 59 | Ada.Exceptions.Save_Occurrence (Mine.all, E.Instance.all); 60 | E.Instance := Mine; 61 | end if; 62 | end Adjust; 63 | 64 | end Rx.Errors; 65 | -------------------------------------------------------------------------------- /src/body/rx-impl-definite_observables.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Impl.Definite_Observables is 2 | 3 | --------------- 4 | -- Subscribe -- 5 | --------------- 6 | 7 | overriding procedure Subscribe 8 | (Producer : in out Observable; 9 | Consumer : in out Contracts.Observer'Class) 10 | is 11 | begin 12 | Producer.Ref.Subscribe (Consumer); 13 | end Subscribe; 14 | 15 | ---------- 16 | -- From -- 17 | ---------- 18 | 19 | function From (Indef : Contracts.Observable'Class) return Observable is 20 | begin 21 | return Hold (Indef); 22 | end From; 23 | 24 | ---------- 25 | -- From -- 26 | ---------- 27 | 28 | procedure From (This : in out Observable; Indef : Contracts.Observable'Class) is 29 | begin 30 | This.Hold (Indef); 31 | end From; 32 | 33 | end Rx.Impl.Definite_Observables; 34 | -------------------------------------------------------------------------------- /src/body/rx-impl-definite_observers.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Impl.Definite_Observers is 2 | 3 | ------------ 4 | -- Create -- 5 | ------------ 6 | 7 | function Create (From : Contracts.Observer'Class) return Observer is 8 | begin 9 | return (Actual => Holders.Hold (From)); 10 | end Create; 11 | 12 | ------------- 13 | -- On_Next -- 14 | ------------- 15 | 16 | overriding procedure On_Next 17 | (This : in out Observer; 18 | V : Contracts.T) 19 | is 20 | begin 21 | This.Actual.Ref.On_Next (V); 22 | end On_Next; 23 | 24 | ------------------ 25 | -- On_Complete -- 26 | ------------------ 27 | 28 | overriding procedure On_Complete (This : in out Observer) is 29 | begin 30 | This.Actual.Ref.On_Complete ; 31 | end On_Complete ; 32 | 33 | -------------- 34 | -- On_Error -- 35 | -------------- 36 | 37 | overriding procedure On_Error 38 | (This : in out Observer; 39 | Error : Errors.Occurrence) 40 | is 41 | begin 42 | This.Actual.Ref.On_Error (Error); 43 | end On_Error; 44 | 45 | -------------- 46 | -- Is_Valid -- 47 | -------------- 48 | 49 | function Is_Valid (This : Observer) return Boolean is 50 | begin 51 | return This.Actual.Is_Valid; 52 | end Is_Valid; 53 | 54 | ----------- 55 | -- Clear -- 56 | ----------- 57 | 58 | procedure Clear (This : in out Observer) is 59 | begin 60 | This.Actual.Clear; 61 | end Clear; 62 | 63 | end Rx.Impl.Definite_Observers; 64 | -------------------------------------------------------------------------------- /src/body/rx-impl-links.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Impl.Links is 4 | 5 | ---------------- 6 | -- Set_Parent -- 7 | ---------------- 8 | 9 | procedure Set_Parent 10 | (This : in out Downstream; 11 | Parent : Typed.Contracts.Observable'Class) 12 | is 13 | begin 14 | -- If operator already has a parent, this means it belongs to a 15 | -- partial chain. We must propagate the parenting up to the first 16 | -- element in the chain. 17 | if This.Parent.Is_Empty then 18 | This.Parent.Hold (Parent); 19 | else 20 | if This.Parent.CRef.Actual.all in Downstream'Class then 21 | declare 22 | Current_Parent : Downstream'Class renames 23 | Downstream'Class (This.Parent.Ref.Actual.all); 24 | begin 25 | Debug.Trace ("Parenting upstream"); 26 | Current_Parent.Set_Parent (Parent); 27 | end; 28 | else 29 | raise Program_Error with "Unexpected unchainable found upstream"; 30 | end if; 31 | end if; 32 | end Set_Parent; 33 | 34 | end Rx.Impl.Links; 35 | -------------------------------------------------------------------------------- /src/body/rx-impl-shared_observer.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Impl.Shared_Observer is 4 | 5 | --------- 6 | -- Ref -- 7 | --------- 8 | 9 | function Ref (This : in out Observer) return Safe_Observers.Ref is 10 | function Tamper is new Safe_Observers.Tamper; 11 | begin 12 | return Tamper (Safe_Observers.Proxy (This)); 13 | end Ref; 14 | 15 | ------------ 16 | -- Create -- 17 | ------------ 18 | 19 | function Create (Held : Typed.Observer; 20 | Checked : Boolean := True) return Observer is 21 | begin 22 | Debug.Trace ("shared_observer [create]"); 23 | return Wrap (new Inner_Observer' 24 | (Actual => Definite_Observers.Create (Held), 25 | Checked => Checked, 26 | Ended => False)); 27 | end Create; 28 | 29 | ------------------ 30 | -- Is_Completed -- 31 | ------------------ 32 | 33 | function Is_Completed (This : Observer) return Boolean is 34 | begin 35 | return This.Get.Ended; 36 | end Is_Completed; 37 | 38 | -------------------- 39 | -- Mark_Completed -- 40 | -------------------- 41 | 42 | procedure Mark_Completed (This : in out Observer) is 43 | begin 44 | Debug.Trace ("shared_observer [mark_completed]"); 45 | This.Ref.Ended := True; 46 | end Mark_Completed; 47 | 48 | ------------- 49 | -- On_Next -- 50 | ------------- 51 | 52 | overriding procedure On_Next 53 | (This : in out Observer; 54 | V : Typed.Type_Traits.T) 55 | is 56 | begin 57 | Debug.Trace ("shared_observer on_next"); 58 | Ref (This).Actual.Actual.On_Next (V); 59 | end On_Next; 60 | 61 | ------------------ 62 | -- On_Complete -- 63 | ------------------ 64 | 65 | overriding procedure On_Complete (This : in out Observer) is 66 | begin 67 | if Ref (This).Ended and then Ref (This).Checked then 68 | Debug.Trace ("shared_observer [double on_complete]"); 69 | raise Program_Error with "Double On_Complete"; 70 | else 71 | Debug.Trace ("shared_observer [on_complete]" & Ref (This).Checked'Img & Ref (This).Ended'Img); 72 | Ref (This).Ended := True; 73 | Ref (This).Actual.Actual.On_Complete; 74 | end if; 75 | end On_Complete; 76 | 77 | -------------- 78 | -- On_Error -- 79 | -------------- 80 | 81 | overriding procedure On_Error 82 | (This : in out Observer; 83 | Error : Errors.Occurrence) 84 | is 85 | begin 86 | if Ref (This).Ended and then Ref (This).Checked then 87 | Debug.Trace ("shared_observer [double on_error]"); 88 | raise Program_Error with "Double On_Error"; 89 | else 90 | Debug.Trace ("shared_observer [on_error]" & Ref (This).Checked'Img & Ref (This).Ended'Img); 91 | Ref (This).Ended := True; 92 | Ref (This).Actual.Actual.On_Error (Error); 93 | end if; 94 | end On_Error; 95 | 96 | end Rx.Impl.Shared_Observer; 97 | -------------------------------------------------------------------------------- /src/body/rx-observables-image.adb: -------------------------------------------------------------------------------- 1 | with Ada.Strings.Unbounded; 2 | 3 | package body Rx.Observables.Image is 4 | 5 | ----------------------- 6 | -- Addressable_Image -- 7 | ----------------------- 8 | 9 | function Addressable_Image (V : T) return String is 10 | begin 11 | return Image (V); 12 | end Addressable_Image; 13 | 14 | ---------------- 15 | -- List_Image -- 16 | ---------------- 17 | 18 | function List_Image (L : T_List) return String is 19 | use Ada.Strings.Unbounded; 20 | 21 | Result : Unbounded_String := To_Unbounded_String ("("); 22 | First : Boolean := True; 23 | begin 24 | for E of L loop 25 | if not First then 26 | Append (Result, ", "); 27 | else 28 | First := False; 29 | end if; 30 | Append (Result, Image (E)); 31 | end loop; 32 | 33 | return To_String (Result & ")"); 34 | end List_Image; 35 | 36 | end Rx.Observables.Image; 37 | -------------------------------------------------------------------------------- /src/body/rx-observables.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Observables is 2 | 3 | ------------ 4 | -- Append -- 5 | ------------ 6 | 7 | procedure Append (L : in out Collections.List; V : T) is 8 | begin 9 | L.Append (V); 10 | end Append; 11 | 12 | -------------- 13 | -- For_Each -- 14 | -------------- 15 | 16 | procedure For_Each (Producer : Typed.Observable; 17 | On_Next : Typed.Actions.Proc1 := null; 18 | On_Complete : Rx.Actions.Proc0 := null; 19 | On_Error : Rx.Actions.Proc_Error := null) 20 | is 21 | S : constant Subscriptions.Subscription := Producer & Subscribe (On_Next, On_Complete , On_Error); 22 | pragma Unreferenced (S); 23 | begin 24 | null; -- Done in the declarative part 25 | end For_Each; 26 | 27 | procedure For_Each (Producer : Typed.Observable; 28 | Consumer : Typed.Sink) 29 | is 30 | S : constant Subscriptions.Subscription := Producer & Consumer 31 | with Unreferenced; 32 | begin 33 | null; -- Done in declarative part 34 | end For_Each; 35 | 36 | ------------- 37 | -- Iterate -- 38 | ------------- 39 | 40 | procedure Iterate (V : T_List; 41 | For_Each : access procedure (V : T)) is 42 | begin 43 | for E of V loop 44 | For_Each (E); 45 | end loop; 46 | end Iterate; 47 | 48 | ---------------- 49 | -- Set_Parent -- 50 | ---------------- 51 | 52 | procedure Set_Parent (This : in out Observable'Class; 53 | Parent : Observable'Class) 54 | is 55 | begin 56 | Operator'Class (This).Set_Parent (Parent); 57 | end Set_Parent; 58 | 59 | end Rx.Observables; 60 | -------------------------------------------------------------------------------- /src/body/rx-op-buffer.adb: -------------------------------------------------------------------------------- 1 | with Rx.Errors; 2 | 3 | package body Rx.Op.Buffer is 4 | 5 | use Transform.Into.Conversions; 6 | 7 | type Counter is new Transform.Operator with record 8 | Container : Transform.Into.D := Empty; 9 | 10 | Need : Positive; 11 | Have : Natural := 0; 12 | 13 | Skip : Natural := 0; 14 | Skipped : Natural := 0; 15 | 16 | Skipping : Boolean := False; 17 | end record; 18 | 19 | overriding procedure On_Next (This : in out Counter; 20 | V : Transform.From.T); 21 | 22 | overriding procedure On_Complete (This : in out Counter); 23 | 24 | overriding procedure On_Error (This : in out Counter; 25 | Error : Errors.Occurrence); 26 | 27 | procedure Emit (This : in out Counter) is 28 | begin 29 | This.Have := 0; 30 | This.Get_Observer.On_Next (+ This.Container); 31 | This.Container := Empty; 32 | end Emit; 33 | 34 | ------------- 35 | -- On_Next -- 36 | ------------- 37 | 38 | overriding procedure On_Next (This : in out Counter; 39 | V : Transform.From.T) is 40 | begin 41 | if This.Skipping then 42 | This.Skipped := This.Skipped + 1; 43 | 44 | if This.Skipped = This.Skip then 45 | This.Skipping := False; 46 | end if; 47 | else 48 | Append (This.Container, V); 49 | This.Have := This.Have + 1; 50 | 51 | if This.Have = This.Need then 52 | Emit (This); 53 | 54 | if This.Skip > 0 then 55 | This.Skipping := True; 56 | This.Skipped := 0; 57 | end if; 58 | end if; 59 | end if; 60 | end On_Next; 61 | 62 | ------------------ 63 | -- On_Complete -- 64 | ------------------ 65 | 66 | overriding procedure On_Complete (This : in out Counter) is 67 | begin 68 | if This.Have > 0 then 69 | Emit (This); 70 | end if; 71 | This.Get_Observer.On_Complete ; 72 | end On_Complete ; 73 | 74 | -------------- 75 | -- On_Error -- 76 | -------------- 77 | 78 | overriding procedure On_Error (This : in out Counter; 79 | Error : Errors.Occurrence) is 80 | begin 81 | if This.Have > 0 then 82 | Emit (This); 83 | This.Get_Observer.On_Error (Error); 84 | end if; 85 | end On_Error; 86 | 87 | ------------ 88 | -- Create -- 89 | ------------ 90 | 91 | function Create 92 | (Every : Positive; 93 | Skip : Natural := 0) 94 | return Transform.Operator'Class 95 | is 96 | begin 97 | return Counter'(Transform.Operator with 98 | Need => Every, 99 | Skip => Skip, 100 | others => <>); 101 | end Create; 102 | 103 | end Rx.Op.Buffer; 104 | -------------------------------------------------------------------------------- /src/body/rx-op-count.adb: -------------------------------------------------------------------------------- 1 | -- with Rx.Debug; 2 | 3 | package body Rx.Op.Count is 4 | 5 | use Transform.Into.Conversions; 6 | 7 | type Counter is new Transform.Operator with record 8 | Count : Transform.Into.Type_Traits.D; 9 | end record; 10 | 11 | overriding 12 | procedure On_Next (This : in out Counter; 13 | V : Transform.From.T); 14 | 15 | overriding 16 | procedure On_Complete (This : in out Counter); 17 | 18 | ------------- 19 | -- On_Next -- 20 | ------------- 21 | 22 | overriding 23 | procedure On_Next (This : in out Counter; 24 | V : Transform.From.T) 25 | is 26 | pragma Unreferenced (V); 27 | begin 28 | This.Count := +Succ (+This.Count); 29 | end On_Next; 30 | 31 | 32 | ------------------ 33 | -- On_Complete -- 34 | ------------------ 35 | 36 | overriding 37 | procedure On_Complete (This : in out Counter) is 38 | begin 39 | This.Get_Observer.On_Next (Transform.Into.Type_Traits.To_Indefinite (This.Count)); 40 | This.Get_Observer.On_Complete; 41 | end On_Complete; 42 | 43 | ----------- 44 | -- Count -- 45 | ----------- 46 | 47 | function Count (First : Transform.Into.T := Default_Initial_Count) return Transform.Operator'Class 48 | is 49 | begin 50 | return Counter'(Transform.Operator with Count => +First); 51 | end Count; 52 | 53 | end Rx.Op.Count; 54 | -------------------------------------------------------------------------------- /src/body/rx-op-distinct.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Distinct is 2 | 3 | type Operator is new Operate.Operator with record 4 | Prev : Operate.Typed.D; 5 | First_Seen : Boolean := False; 6 | Are_Distinct : Operate.Typed.Actions.Comparator; 7 | end record; 8 | 9 | overriding procedure On_Next (This : in out Operator; V : Operate.T) is 10 | use Operate.Typed.Conversions; 11 | begin 12 | if This.First_Seen then 13 | if This.Are_Distinct (V, + This.Prev) then 14 | This.Get_Observer.On_Next (V); 15 | This.Prev := + V; 16 | end if; 17 | else 18 | This.First_Seen := True; 19 | This.Prev := + V; 20 | end if; 21 | end On_Next; 22 | 23 | ------------ 24 | -- Create -- 25 | ------------ 26 | 27 | function Create 28 | (Are_Distinct : Operate.Typed.Actions.Comparator := Default_Not_Same'Access) 29 | return Operate.Operator'Class 30 | is 31 | begin 32 | return Operator'(Operate.Operator with Are_Distinct => Are_Distinct, others => <>); 33 | end Create; 34 | 35 | end Rx.Op.Distinct; 36 | -------------------------------------------------------------------------------- /src/body/rx-op-do_on.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Do_On is 2 | 3 | type Operator is new Preserver.Operator with record 4 | On_Next : Preserver.Typed.Actions.HTProc1; 5 | end record; 6 | 7 | overriding procedure On_Next (This : in out Operator; 8 | V : Preserver.T); 9 | 10 | ------------ 11 | -- Create -- 12 | ------------ 13 | 14 | function Create (On_Next : Preserver.Typed.Actions.TProc1'Class) 15 | return Preserver.Operator'Class 16 | is 17 | use Preserver.Typed.Actions; 18 | begin 19 | return Operator'(Preserver.Operator with On_Next => Hold (On_Next)); 20 | end Create; 21 | 22 | 23 | ------------- 24 | -- On_Next -- 25 | ------------- 26 | 27 | overriding procedure On_Next (This : in out Operator; 28 | V : Preserver.T) is 29 | begin 30 | This.On_Next.Ref.Call (V); 31 | This.Get_Observer.On_Next (V); 32 | end On_Next; 33 | 34 | end Rx.Op.Do_On; 35 | -------------------------------------------------------------------------------- /src/body/rx-op-element_at.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Element_At is 2 | 3 | use Operate.Typed.Conversions; 4 | 5 | type Operator (Pos : Rx_Integer) is new Operate.Operator with record 6 | Has_Default : Boolean := False; 7 | Default : Operate.Typed.D; 8 | 9 | Current : Rx_Integer; 10 | end record; 11 | 12 | overriding procedure On_Next (This : in out Operator; V : Operate.T); 13 | 14 | overriding procedure On_Complete (This : in out Operator); 15 | 16 | overriding procedure On_Next (This : in out Operator; V : Operate.T) is 17 | begin 18 | if This.Current = This.Pos then 19 | This.Get_Observer.On_Next (V); 20 | This.Get_Observer.On_Complete ; 21 | end if; 22 | 23 | This.Current := This.Current + 1; 24 | end On_Next; 25 | 26 | overriding procedure On_Complete (This : in out Operator) is begin 27 | if This.Current <= This.Pos then 28 | if not This.Has_Default then 29 | raise Constraint_Error with "Pos not reached in Element_At"; 30 | else 31 | This.Get_Observer.On_Next (+ This.Default); 32 | This.Get_Observer.On_Complete ; 33 | end if; 34 | else 35 | null; -- Otherwise we already completed in On_Next 36 | end if; 37 | end On_Complete ; 38 | 39 | ------------ 40 | -- Create -- 41 | ------------ 42 | 43 | function Create 44 | (Pos : Rx_Integer; 45 | First : Rx_Integer := 1) 46 | return Operate.Operator'Class 47 | is 48 | begin 49 | return Operator'(Operate.Operator with 50 | Pos => Pos, 51 | Has_Default => False, 52 | Default => <>, 53 | Current => First); 54 | end Create; 55 | 56 | ---------------- 57 | -- Or_Default -- 58 | ---------------- 59 | 60 | function Or_Default 61 | (Default : Operate.T; 62 | Pos : Rx_Integer; 63 | First : Rx_Integer := 1) 64 | return Operate.Operator'Class 65 | is 66 | begin 67 | return Operator'(Operate.Operator with 68 | Pos => Pos, 69 | Has_Default => True, 70 | Default => +Default, 71 | Current => First); 72 | end Or_Default; 73 | 74 | end Rx.Op.Element_At; 75 | -------------------------------------------------------------------------------- /src/body/rx-op-filter.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Filter is 2 | 3 | type Operator is new Operate.Operator with record 4 | Func : Operate.Typed.Actions.HTFilter1; 5 | end record; 6 | 7 | overriding 8 | procedure On_Next (This : in out Operator; 9 | V : Operate.T) 10 | is 11 | begin 12 | if This.Func.Ref.Check (V) then 13 | This.Get_Observer.On_Next (V); 14 | end if; 15 | end On_Next; 16 | 17 | ------------ 18 | -- Create -- 19 | ------------ 20 | 21 | function Create (Filter : not null Operate.Typed.Actions.Filter1) 22 | return Operate.Operator'Class 23 | is 24 | (Create (Operate.Typed.Actions.Wrap (Filter))); 25 | 26 | ------------ 27 | -- Create -- 28 | ------------ 29 | 30 | function Create (Filter : Operate.Typed.Actions.TFilter1'Class) 31 | return Operate.Operator'Class 32 | is 33 | use Operate.Typed.Actions; 34 | begin 35 | return Operator'(Operate.Operator with +Filter); 36 | end Create; 37 | 38 | end Rx.Op.Filter; 39 | -------------------------------------------------------------------------------- /src/body/rx-op-funnel.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | with Rx.Impl.Shared_Observer; 3 | with Rx.Op.Serialize; 4 | 5 | package body Rx.Op.Funnel is 6 | 7 | package RxSerialize is new Rx.Op.Serialize (Preserver); 8 | 9 | package Shared_Observers is new Impl.Shared_Observer (Preserver.Typed); 10 | 11 | type Operator is new Preserver.Operator with null record; 12 | 13 | overriding procedure On_Next (This : in out Operator; V : Preserver.T); 14 | 15 | overriding procedure Subscribe (This : in out Operator; 16 | Consumer : in out Preserver.Observer'Class); 17 | 18 | ------------ 19 | -- Create -- 20 | ------------ 21 | 22 | function Create return Preserver.Operator'Class is 23 | use Preserver.Linkers; 24 | begin 25 | return 26 | Preserver.Operator'Class 27 | (RxSerialize.Create 28 | & Operator'(Preserver.Operator with null record)); 29 | end Create; 30 | 31 | ------------- 32 | -- On_Next -- 33 | ------------- 34 | 35 | overriding procedure On_Next (This : in out Operator; V : Preserver.T) is 36 | begin 37 | Debug.Trace ("funnel on_next"); 38 | This.Get_Observer.On_Next (V); 39 | end On_Next; 40 | 41 | --------------- 42 | -- Subscribe -- 43 | --------------- 44 | 45 | overriding procedure Subscribe (This : in out Operator; 46 | Consumer : in out Preserver.Observer'Class) 47 | is 48 | Shared : Shared_Observers.Observer := 49 | Shared_Observers.Create (Consumer, 50 | Checked => False); 51 | begin 52 | Preserver.Operator (This).Subscribe (Shared); 53 | end Subscribe; 54 | 55 | end Rx.Op.Funnel; 56 | -------------------------------------------------------------------------------- /src/body/rx-op-hold.adb: -------------------------------------------------------------------------------- 1 | with Ada.Numerics.Float_Random; 2 | 3 | with Rx.Debug; 4 | 5 | package body Rx.Op.Hold is 6 | 7 | --------------- 8 | -- Generator -- 9 | --------------- 10 | 11 | protected Generator is 12 | procedure Get (F : out Float); 13 | private 14 | State : Ada.Numerics.Float_Random.Generator; 15 | end Generator; 16 | 17 | protected body Generator is 18 | 19 | procedure Get (F : out Float) is 20 | begin 21 | F := Ada.Numerics.Float_Random.Random (State); 22 | end Get; 23 | 24 | end Generator; 25 | 26 | ------------ 27 | -- Random -- 28 | ------------ 29 | 30 | function Random return Ada.Numerics.Float_Random.Uniformly_Distributed is 31 | F : Float; 32 | begin 33 | Generator.Get (F); 34 | return F; 35 | end Random; 36 | 37 | type Operator is new Preserver.Operator with record 38 | Fixed, 39 | Random: Float; 40 | end record; 41 | 42 | overriding procedure On_Next (This : in out Operator; 43 | V : Preserver.T); 44 | 45 | ------------ 46 | -- Create -- 47 | ------------ 48 | 49 | function Create (Fixed : Duration; 50 | Random : Duration := 0.0) 51 | return Preserver.Operator'Class is 52 | begin 53 | return Operator'(Preserver.Operator with 54 | Fixed => Float (Fixed), 55 | Random => Float (Random)); 56 | end Create; 57 | 58 | ------------- 59 | -- On_Next -- 60 | ------------- 61 | 62 | overriding procedure On_Next (This : in out Operator; 63 | V : Preserver.T) 64 | is 65 | Pause : constant Float := This.Fixed + This.Random * Random; 66 | Dur : constant Duration := Duration (Pause); 67 | begin 68 | Debug.Trace ("on_next hold:" & Dur'Img); 69 | delay Dur; 70 | This.Get_Observer.On_Next (V); 71 | end On_Next; 72 | 73 | end Rx.Op.Hold; 74 | -------------------------------------------------------------------------------- /src/body/rx-op-last.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Last is 2 | 3 | use Operate.Typed.Conversions; 4 | 5 | type Operator is new Operate.Operator with record 6 | Filter : Operate.Typed.Actions.HTFilter1; 7 | 8 | Has_Last : Boolean := False; 9 | Last : Operate.Typed.D; 10 | end record; 11 | 12 | overriding 13 | procedure On_Next (This : in out Operator; 14 | V : Operate.T); 15 | 16 | overriding 17 | procedure On_Complete (This : in out Operator); 18 | 19 | ------------- 20 | -- On_Next -- 21 | ------------- 22 | 23 | overriding 24 | procedure On_Next (This : in out Operator; 25 | V : Operate.Typed.T) 26 | is 27 | begin 28 | if This.Filter.Ref.Check (V) then 29 | This.Last := + V; 30 | This.Has_Last := True; 31 | end if; 32 | end On_Next; 33 | 34 | ------------------ 35 | -- On_Complete -- 36 | ------------------ 37 | 38 | overriding 39 | procedure On_Complete (This : in out Operator) is 40 | begin 41 | if This.Has_Last then 42 | This.Get_Observer.On_Next (+ This.Last); 43 | This.Get_Observer.On_Complete ; 44 | else 45 | raise Constraint_Error with "Last completed without element"; 46 | end if; 47 | end On_Complete ; 48 | 49 | ------------ 50 | -- Create -- 51 | ------------ 52 | 53 | function Create 54 | (Check : Operate.Typed.Actions.TFilter1'Class := Operate.Typed.Actions.Always_Pass) 55 | return Operate.Operator'Class 56 | is 57 | use Operate.Typed.Actions; 58 | begin 59 | return 60 | (Operator'(Operate.Operator with 61 | Has_Last => False, 62 | Filter => + Check, 63 | others => <>)); 64 | end Create; 65 | 66 | ---------------- 67 | -- Or_Default -- 68 | ---------------- 69 | 70 | function Or_Default 71 | (Default : Operate.T; 72 | Check : Operate.Typed.Actions.TFilter1'Class := Operate.Typed.Actions.Always_Pass) 73 | return Operate.Operator'Class 74 | is 75 | use Operate.Typed.Actions; 76 | begin 77 | return 78 | (Operator'(Operate.Operator with 79 | Has_Last => True, 80 | Last => + Default, 81 | Filter => + Check)); 82 | end Or_Default; 83 | 84 | end Rx.Op.Last; 85 | -------------------------------------------------------------------------------- /src/body/rx-op-length.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Length is 2 | 3 | type Transformer is new Transform.Operator with null record; 4 | 5 | overriding procedure On_Next (This : in out Transformer; 6 | V : Transform.From.T) 7 | is 8 | begin 9 | This.Get_Observer.On_Next (Length (V)); 10 | end On_Next; 11 | 12 | ------------ 13 | -- Create -- 14 | ------------ 15 | 16 | function Create return Transform.Operator'Class is 17 | begin 18 | return Transformer'(Transform.Operator with null record); 19 | end Create; 20 | 21 | end Rx.Op.Length; 22 | -------------------------------------------------------------------------------- /src/body/rx-op-limit.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Op.Limit is 4 | 5 | type Operator is new Operate.Operator with record 6 | Remaining : Rx_Natural; 7 | Completed : Boolean := False; 8 | end record; 9 | 10 | overriding procedure On_Next (This : in out Operator; 11 | V : Operate.T); 12 | 13 | overriding procedure On_Complete (This : in out Operator); 14 | 15 | ------------------ 16 | -- On_Complete -- 17 | ------------------ 18 | 19 | overriding procedure On_Complete (This : in out Operator) is 20 | begin 21 | if not This.Completed then 22 | Debug.Trace ("limit on_complete [completing]"); 23 | This.Completed := True; 24 | This.Get_Observer.On_Complete ; 25 | This.Unsubscribe; 26 | else 27 | Debug.Trace ("limit on_complete [after completed]"); 28 | -- raise No_Longer_Subscribed; 29 | -- Not really necessary to raise, since no more calls are expected. 30 | -- This may happen e.g. with Just (V) & Limit (0) 31 | -- Limit will complete on the single V and Just.On_Complete will 32 | -- trigger this case. 33 | -- This was discovered during tests with Flat_Map. 34 | end if; 35 | end On_Complete ; 36 | 37 | ------------- 38 | -- On_Next -- 39 | ------------- 40 | 41 | overriding procedure On_Next (This : in out Operator; 42 | V : Operate.T) 43 | is 44 | begin 45 | if This.Completed then 46 | Debug.Trace ("limit on_next after completed"); 47 | raise No_Longer_Subscribed; 48 | end if; 49 | 50 | if This.Remaining > 0 then 51 | Debug.Trace ("limit on_next"); 52 | This.Get_Observer.On_Next (V); 53 | This.Remaining := This.Remaining - 1; 54 | end if; 55 | 56 | if This.Remaining = 0 and not This.Completed then 57 | Debug.Trace ("limit on_next completing"); 58 | This.Completed := True; 59 | This.Get_Observer.On_Complete ; 60 | This.Unsubscribe; 61 | end if; 62 | end On_Next; 63 | 64 | ------------ 65 | -- Create -- 66 | ------------ 67 | 68 | function Create (Limit : Rx_Natural) return Operate.Operator'Class is 69 | begin 70 | return Operator'(Operate.Operator with 71 | Remaining => Limit, 72 | Completed => False); 73 | end Create; 74 | 75 | 76 | end Rx.Op.Limit; 77 | -------------------------------------------------------------------------------- /src/body/rx-op-map.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Map is 2 | 3 | type Op (F : Typed.Actions.Func1) is new Typed.Operator with null record; 4 | 5 | overriding 6 | procedure On_Next (This : in out Op; 7 | V : Typed.From.Type_Traits.T) is 8 | begin 9 | This.Get_Observer.On_Next (This.F (V)); 10 | end On_Next; 11 | 12 | ------------ 13 | -- Create -- 14 | ------------ 15 | 16 | function Create (F : Typed.Actions.Func1) return Typed.Operator'Class is 17 | begin 18 | return Op'(Typed.Operator with F => F); 19 | end Create; 20 | 21 | --------- 22 | -- "&" -- 23 | --------- 24 | 25 | function "&" (Producer : Typed.From.Observable; 26 | Consumer : Typed.Actions.Func1) 27 | return Typed.Into.Observable is 28 | (Typed.Concatenate (Producer, Create (Consumer))); 29 | 30 | end Rx.Op.Map; 31 | -------------------------------------------------------------------------------- /src/body/rx-op-no_op.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Op.No_Op is 4 | 5 | type Operator is new Preserver.Operator with null record; 6 | 7 | overriding procedure On_Next (This : in out Operator; 8 | V : Preserver.T); 9 | 10 | ------------ 11 | -- Create -- 12 | ------------ 13 | 14 | function Create return Preserver.Operator'Class is 15 | begin 16 | return Operator'(Preserver.Operator with null record); 17 | end Create; 18 | 19 | ------------- 20 | -- On_Next -- 21 | ------------- 22 | 23 | overriding procedure On_Next (This : in out Operator; 24 | V : Preserver.T) 25 | is 26 | begin 27 | Debug.Trace ("on_next"); 28 | This.Get_Observer.On_Next (V); 29 | end On_Next; 30 | 31 | end Rx.Op.No_Op; 32 | -------------------------------------------------------------------------------- /src/body/rx-op-observe_on.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | with Rx.Dispatchers; 3 | with Rx.Errors; 4 | 5 | -- with Gnat.Io; use Gnat.Io; 6 | 7 | package body Rx.Op.Observe_On is 8 | 9 | package Remote is new Dispatchers.Events (Operate.Typed); 10 | package Shared renames Remote.Shared; 11 | 12 | type Op is new Operate.Operator with record 13 | Scheduler : Schedulers.Scheduler; 14 | Thread : Schedulers.Thread; 15 | Subscriber : Shared.Observer; 16 | end record; 17 | 18 | overriding procedure On_Next (This : in out Op; V : Operate.T); 19 | overriding procedure On_Complete (This : in out Op); 20 | overriding procedure On_Error (This : in out Op; Error : Errors.Occurrence); 21 | 22 | overriding procedure Subscribe (This : in out Op; Observer : in out Operate.Into.Observer'Class); 23 | 24 | ------------- 25 | -- On_Next -- 26 | ------------- 27 | 28 | overriding procedure On_Next (This : in out Op; V : Operate.T) is 29 | begin 30 | Debug.Trace ("on_next"); 31 | Remote.On_Next (This.Thread.all, This.Subscriber, V); 32 | end On_Next; 33 | 34 | ------------------ 35 | -- On_Complete -- 36 | ------------------ 37 | 38 | overriding procedure On_Complete (This : in out Op) is 39 | begin 40 | Debug.Trace ("on_complete"); 41 | Remote.On_Complete (This.Thread.all, This.Subscriber); 42 | end On_Complete ; 43 | 44 | -------------- 45 | -- On_Error -- 46 | -------------- 47 | 48 | overriding procedure On_Error (This : in out Op; Error : Errors.Occurrence) is 49 | begin 50 | Debug.Trace ("on_error"); 51 | Remote.On_Error (This.Thread.all, This.Subscriber, Error); 52 | end On_Error; 53 | 54 | --------------- 55 | -- Subscribe -- 56 | --------------- 57 | 58 | overriding procedure Subscribe (This : in out Op; Observer : in out Operate.Into.Observer'Class) is 59 | begin 60 | This.Subscriber := Shared.Create (Observer, Checked => False); 61 | -- Not our business to check integrity, there are plenty others doing it, 62 | -- and this one is heavily used by merge/flatmap, which rely on uncheckedness 63 | 64 | This.Thread := This.Scheduler.Get_Thread; 65 | 66 | Operate.Operator (This).Subscribe (This.Subscriber); 67 | end Subscribe; 68 | 69 | ------------ 70 | -- Create -- 71 | ------------ 72 | 73 | function Create (Scheduler : Schedulers.Scheduler) return Operate.Operator'Class is 74 | begin 75 | return Op'(Operate.Operator with 76 | Scheduler => Scheduler, 77 | Thread => <>, 78 | Subscriber => <>); -- To be set during subscription 79 | end Create; 80 | 81 | end Rx.Op.Observe_On; 82 | -------------------------------------------------------------------------------- /src/body/rx-op-print.adb: -------------------------------------------------------------------------------- 1 | with Ada.Calendar.Formatting; 2 | 3 | with Ada.Text_IO; 4 | 5 | with Rx.Schedulers; 6 | 7 | package body Rx.Op.Print is 8 | 9 | use Ada.Calendar; 10 | 11 | function Stamp return String is 12 | (Formatting.Image (Clock, Include_Time_Fraction => True) & ": "); 13 | 14 | type Op (Func : Operate.Typed.Actions.Func1Str) is new Operate.Operator with record 15 | With_Timestamp : Boolean := True; 16 | end record; 17 | 18 | overriding procedure On_Next (This : in out Op; V : Operate.T) is 19 | use Ada.Text_IO; 20 | use Operate.Typed.Actions; 21 | begin 22 | if This.Func /= null then 23 | Put_Line ((if This.With_Timestamp then Stamp else "") & This.Func (V)); 24 | else 25 | Put_Line ((if This.With_Timestamp then Stamp else "") & Rx.Schedulers.Current_Thread_Id); -- Mmm 26 | end if; 27 | This.Get_Observer.On_Next (V); 28 | end On_Next; 29 | 30 | ------------ 31 | -- Create -- 32 | ------------ 33 | 34 | function Create (Func : Operate.Typed.Actions.Func1Str := null; With_Timestamp : Boolean := True) return Operate.Operator'Class is 35 | begin 36 | return Op'(Operate.Operator 37 | with Func => Func, With_Timestamp => With_Timestamp); 38 | end Create; 39 | 40 | end Rx.Op.Print; 41 | -------------------------------------------------------------------------------- /src/body/rx-op-sample.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Sample is 2 | 3 | ------------ 4 | -- Create -- 5 | ------------ 6 | 7 | function Create 8 | (Policy : Policies; 9 | Sampler : Samplers.Observable'Class) 10 | return Operate.Operator'Class 11 | is 12 | begin 13 | raise Unimplemented; 14 | return Create (Policy, Sampler); 15 | end Create; 16 | 17 | end Rx.Op.Sample; 18 | -------------------------------------------------------------------------------- /src/body/rx-op-scan.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Scan is 2 | 3 | use Typed.Into.Conversions; 4 | 5 | type Operator is new Typed.Operator with record 6 | Func : Typed.Actions.Func2; 7 | Acum : Typed.Into.D; 8 | Emit : Boolean; 9 | end record; 10 | 11 | overriding 12 | procedure Subscribe (Producer : in out Operator; 13 | Consumer : in out Typed.Into.Observer'Class); 14 | 15 | overriding 16 | procedure On_Next (This : in out Operator; 17 | V : Typed.From.T); 18 | 19 | --------------- 20 | -- Subscribe -- 21 | --------------- 22 | 23 | overriding 24 | procedure Subscribe (Producer : in out Operator; 25 | Consumer : in out Typed.Into.Observer'Class) 26 | is 27 | begin 28 | Typed.Operator (Producer).Subscribe (Consumer); 29 | if Producer.Emit then 30 | Producer.Get_Observer.On_Next (+ Producer.Acum); 31 | end if; 32 | end Subscribe; 33 | 34 | ------------- 35 | -- On_Next -- 36 | ------------- 37 | 38 | overriding 39 | procedure On_Next (This : in out Operator; 40 | V : Typed.From.T) 41 | is 42 | begin 43 | This.Acum := + This.Func (V, + This.Acum); 44 | This.Get_Observer.On_Next (+ This.Acum); 45 | end On_Next; 46 | 47 | ------------ 48 | -- Create -- 49 | ------------ 50 | 51 | function Create 52 | (Func : Typed.Actions.Func2; 53 | Seed : Typed.Into.T; 54 | Emit : Boolean := False) 55 | return Typed.Operator'Class 56 | is 57 | begin 58 | return (Operator'(Typed.Operator with 59 | Func => Func, 60 | Acum => + Seed, 61 | Emit => Emit)); 62 | end Create; 63 | 64 | end Rx.Op.Scan; 65 | -------------------------------------------------------------------------------- /src/body/rx-op-serialize.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | with Rx.Errors; 3 | with Rx.Tools.Semaphores; 4 | 5 | package body Rx.Op.Serialize is 6 | 7 | subtype Critical_Section is Tools.Semaphores.Critical_Section; 8 | 9 | type Serializer is new Operate.Operator with record 10 | Mutex : aliased Tools.Semaphores.Shared; 11 | end record; 12 | 13 | overriding procedure On_Next (This : in out Serializer; V : Operate.T); 14 | 15 | overriding procedure On_Complete (This : in out Serializer); 16 | 17 | overriding procedure On_Error (This : in out Serializer; Error : Errors.Occurrence); 18 | 19 | ------------- 20 | -- On_Next -- 21 | ------------- 22 | 23 | overriding procedure On_Next (This : in out Serializer; V : Operate.T) is 24 | CS : Critical_Section (This.Mutex'Access) with Unreferenced; 25 | begin 26 | Debug.Trace ("serialize on_next"); 27 | This.Get_Observer.On_Next (V); 28 | end On_Next; 29 | 30 | ------------------ 31 | -- On_Complete -- 32 | ------------------ 33 | 34 | overriding procedure On_Complete (This : in out Serializer) is 35 | CS : Critical_Section (This.Mutex'Access) with Unreferenced; 36 | begin 37 | Debug.Trace ("serialize on_complete"); 38 | This.Get_Observer.On_Complete ; 39 | end On_Complete ; 40 | 41 | -------------- 42 | -- On_Error -- 43 | -------------- 44 | 45 | overriding procedure On_Error (This : in out Serializer; Error : Errors.Occurrence) is 46 | CS : Critical_Section (This.Mutex'Access) with Unreferenced; 47 | begin 48 | Debug.Trace ("serialize on_error"); 49 | This.Get_Observer.On_Error (Error); 50 | end On_Error; 51 | 52 | ------------ 53 | -- Create -- 54 | ------------ 55 | 56 | function Create return Operate.Operator'Class is 57 | begin 58 | return Serializer'(Operate.Operator with 59 | Mutex => Tools.Semaphores.Create_Reentrant); 60 | end Create; 61 | 62 | end Rx.Op.Serialize; 63 | -------------------------------------------------------------------------------- /src/body/rx-op-split.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Split is 2 | 3 | type Operator is new Transform.Operator with null record; 4 | 5 | overriding procedure On_Next (This : in out Operator; 6 | V : Transform.From.T) 7 | is 8 | procedure For_Each (V : Transform.Into.T) is 9 | begin 10 | This.Get_Observer.On_Next (V); 11 | end For_Each; 12 | begin 13 | Iterate (V, For_Each'Access); 14 | end On_Next; 15 | 16 | ------------ 17 | -- Create -- 18 | ------------ 19 | 20 | function Create return Transform.Operator'Class is 21 | begin 22 | return Operator'(Transform.Operator with null record); 23 | end Create; 24 | 25 | end Rx.Op.Split; 26 | -------------------------------------------------------------------------------- /src/body/rx-op-subscribe_on.adb: -------------------------------------------------------------------------------- 1 | with Rx.Dispatchers; 2 | 3 | -- with Gnat.Io; use Gnat.Io; 4 | 5 | package body Rx.Op.Subscribe_On is 6 | 7 | package Remote is new Dispatchers.Subscribe (Operate); 8 | 9 | -- This special in that, since it interrupts the subscription chain, can't be implemented with 10 | -- the usual Operator 11 | type Op is new Operate.Operator with record 12 | Sched : Schedulers.Scheduler; 13 | end record; 14 | 15 | overriding procedure Subscribe (This : in out Op; Observer : in out Operate.Into.Observer); 16 | 17 | --------------- 18 | -- Subscribe -- 19 | --------------- 20 | 21 | overriding procedure Subscribe (This : in out Op; Observer : in out Operate.Into.Observer) is 22 | begin 23 | -- Relay subscription to the actual thread: 24 | Remote.On_Subscribe (This.Sched.Get_Thread.all, This.Get_Parent, Observer); 25 | end Subscribe; 26 | 27 | ------------ 28 | -- Create -- 29 | ------------ 30 | 31 | function Create (Scheduler : Schedulers.Scheduler) return Operate.Operator'Class is 32 | begin 33 | return Op'(Operate.Operator with Sched => Scheduler); 34 | end Create; 35 | 36 | end Rx.Op.Subscribe_On; 37 | -------------------------------------------------------------------------------- /src/body/rx-op-take.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Op.Take is 2 | 3 | subtype Parent is Operate.Operator; 4 | 5 | type Operator is new Parent with record 6 | Pass : Actions.HTFilter1; 7 | Emit_Last : Boolean; 8 | end record; 9 | 10 | ------------- 11 | -- On_Next -- 12 | ------------- 13 | 14 | overriding procedure On_Next (This : in out Operator; V : Operate.T) is 15 | begin 16 | if This.Is_Subscribed then 17 | if This.Pass.Ref.Check (V) then 18 | This.Get_Observer.On_Next (V); 19 | else 20 | if This.Emit_Last then 21 | This.Get_Observer.On_Next (V); 22 | end if; 23 | This.Get_Observer.On_Complete ; 24 | This.Unsubscribe; 25 | end if; 26 | else 27 | raise No_Longer_Subscribed; 28 | end if; 29 | end On_Next; 30 | 31 | ------------ 32 | -- Create -- 33 | ------------ 34 | 35 | function Create 36 | (Pass : Actions.TFilter1'Class; 37 | Emit_Last : Boolean) 38 | return Operate.Operator'Class 39 | is 40 | begin 41 | return Operator'(Parent with Pass => Actions.Hold (Pass), Emit_Last => Emit_Last); 42 | end Create; 43 | 44 | ---------------- 45 | -- Take_Count -- 46 | ---------------- 47 | 48 | function Take_Count (Count : Rx_Natural) return Operate.Operator'Class is 49 | begin 50 | return Create (Actions.Countdown (Count), Emit_Last => False); 51 | end Take_Count; 52 | 53 | ---------------- 54 | -- Take_While -- 55 | ---------------- 56 | 57 | function Take_While 58 | (Check : Actions.TFilter1'Class) 59 | return Operate.Operator'Class 60 | is 61 | begin 62 | return Create (Check, Emit_Last => False); 63 | end Take_While; 64 | 65 | ---------------- 66 | -- Take_Until -- 67 | ---------------- 68 | 69 | function Take_Until 70 | (Check : Actions.TFilter1'Class) 71 | return Operate.Operator'Class 72 | is 73 | use Actions; 74 | begin 75 | return Create (not Check, Emit_Last => True); 76 | end Take_Until; 77 | 78 | ------------ 79 | -- Create -- 80 | ------------ 81 | 82 | function Create (During : Duration) return Operate.Operator'Class is 83 | begin 84 | -- Generated stub: replace with real body! 85 | raise Program_Error with "Unimplemented function Create"; 86 | return Create (During => During); 87 | end Create; 88 | 89 | end Rx.Op.Take; 90 | -------------------------------------------------------------------------------- /src/body/rx-schedulers-pools.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Schedulers.Pools is 2 | 3 | ------------ 4 | -- Create -- 5 | ------------ 6 | 7 | function Create (Size : Positive; Name : String := "") return Pool is 8 | begin 9 | if Name = "" then 10 | return Create (Size, "anon of size" & Size'Img); 11 | else 12 | return Unused : Pool (Size, new String'(Name)); 13 | end if; 14 | end Create; 15 | 16 | end Rx.Schedulers.Pools; 17 | -------------------------------------------------------------------------------- /src/body/rx-src-defer.adb: -------------------------------------------------------------------------------- 1 | with Rx.Tools.Holders; 2 | 3 | package body Rx.Src.Defer is 4 | 5 | package Holders is new Rx.Tools.Holders (Factories.Observable_Factory'Class, 6 | "defer.factory'class"); 7 | 8 | type Some_Factory is new Holders.Definite with null record; 9 | 10 | type Observable is new Typed.Contracts.Observable with record 11 | Factory : Some_Factory; 12 | end record; 13 | 14 | overriding 15 | procedure Subscribe (Producer : in out Observable; 16 | Consumer : in out Typed.Observer'Class) 17 | is 18 | Actual : Typed.Observable'Class := Producer.Factory.CRef.Subscribe; 19 | begin 20 | Actual.Subscribe (Consumer); 21 | end Subscribe; 22 | 23 | ------------ 24 | -- Create -- 25 | ------------ 26 | 27 | function Create (F : Factories.Observable_Factory'Class) return Typed.Observable is 28 | begin 29 | return Observable'(Typed.Contracts.Observable with Factory => Hold (F)); 30 | end Create; 31 | 32 | type Func_Factory is new Factories.Observable_Factory with record 33 | Func : Factories.Observable_Factory_Func; 34 | end record; 35 | 36 | overriding function Subscribe (F : Func_Factory) return Typed.Observable is (F.Func.all); 37 | 38 | function Create (F : Factories.Observable_Factory_Func) return Typed.Observable is 39 | begin 40 | return Observable'(Typed.Contracts.Observable with Factory => Hold (Func_Factory'(Func => F))); 41 | end Create; 42 | 43 | end Rx.Src.Defer; 44 | -------------------------------------------------------------------------------- /src/body/rx-src-empty.adb: -------------------------------------------------------------------------------- 1 | with Rx.Src.Create; 2 | 3 | package body Rx.Src.Empty is 4 | 5 | package Create is new Src.Create (Typed); 6 | 7 | type Void is null record; 8 | 9 | procedure On_Subscribe (State : Void; 10 | Observer : in out Typed.Observer) is null; 11 | 12 | package Empty_Sources is new Create.With_State (Void); 13 | 14 | ----------- 15 | -- Empty -- 16 | ----------- 17 | 18 | function Empty return Typed.Observable is 19 | begin 20 | return Empty_Sources.Create (Void'(null record)); 21 | end Empty; 22 | 23 | ----------- 24 | -- Never -- 25 | ----------- 26 | 27 | package Never_Sources is new Create.With_State (Void, Autocompletes => False); 28 | 29 | function Never return Typed.Observable is 30 | begin 31 | return Never_Sources.Create (Void'(null record)); 32 | end Never; 33 | 34 | ----------- 35 | -- Error -- 36 | ----------- 37 | 38 | procedure On_Subscribe_Error (Error : Errors.Occurrence; 39 | Observer : in out Typed.Observer) 40 | is 41 | begin 42 | Observer.On_Error (Error); 43 | end On_Subscribe_Error; 44 | 45 | package Error_Sources is new Create.With_State (Errors.Occurrence, On_Subscribe_Error, Autocompletes => False); 46 | 47 | function Error 48 | (E : Rx.Errors.Occurrence) 49 | return Typed.Observable 50 | is 51 | begin 52 | return Error_Sources.Create (E); 53 | end Error; 54 | 55 | ----------- 56 | -- Error -- 57 | ----------- 58 | 59 | function Error 60 | (E : Ada.Exceptions.Exception_Occurrence) 61 | return Typed.Observable 62 | is 63 | Err : Errors.Occurrence; 64 | begin 65 | Err.Fill (E); 66 | return Error (Err); 67 | end Error; 68 | 69 | end Rx.Src.Empty; 70 | -------------------------------------------------------------------------------- /src/body/rx-src-from.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | with Rx.Tools.Holders; 3 | with Rx.Src.Create; 4 | 5 | package body Rx.Src.From is 6 | 7 | ---------------- 8 | -- From_Array -- 9 | ---------------- 10 | 11 | package body From_Array is 12 | 13 | package Create is new Src.Create (Arrays.Typed); 14 | 15 | package State is new Tools.Holders (Arrays.Typed_Array); 16 | 17 | procedure On_Subscribe (S : State.Definite; 18 | Consumer : in out Arrays.Typed.Observer) is 19 | begin 20 | for E of S.CRef loop 21 | Consumer.On_Next (Arrays.Typed.Type_Traits.To_Indefinite (E)); 22 | end loop; 23 | end On_Subscribe; 24 | 25 | package Arrayed is new Create.With_State (State.Definite, On_Subscribe); 26 | 27 | function From (A : Arrays.Typed_Array) return Arrays.Typed.Contracts.Observable'Class 28 | is 29 | begin 30 | return Arrayed.Create (State.Hold (A)); 31 | end From; 32 | 33 | end From_Array; 34 | 35 | ------------------- 36 | -- From_Iterable -- 37 | ------------------- 38 | 39 | package body From_Iterable is 40 | 41 | package Create is new Src.Create (Iterable.Typed); 42 | 43 | procedure On_Subscribe (State : Iterable.Container; 44 | Consumer : in out Iterable.Typed.Observer) 45 | is 46 | procedure For_Each (V : Iterable.Typed.T) is 47 | begin 48 | Consumer.On_Next (V); 49 | end For_Each; 50 | begin 51 | Iterable.Iterate (State, For_Each'Access); 52 | exception 53 | when No_Longer_Subscribed => 54 | Debug.Log ("From_Iterable: caught No_Longer_Subscribed", Debug.Note); 55 | end On_Subscribe; 56 | 57 | package Iterables is new Create.With_State (Iterable.Container, On_Subscribe); 58 | 59 | function From (C : Iterable.Container) return Iterable.Typed.Contracts.Observable'Class is 60 | begin 61 | return Iterables.Create (C); 62 | end From; 63 | 64 | end From_Iterable; 65 | 66 | end Rx.Src.From; 67 | -------------------------------------------------------------------------------- /src/body/rx-src-interval.adb: -------------------------------------------------------------------------------- 1 | with Ada.Calendar; 2 | 3 | with Rx.Debug; 4 | with Rx.Dispatchers; 5 | with Rx.Impl.Shared_Observer; 6 | with Rx.Src.Create; 7 | 8 | package body Rx.Src.Interval is 9 | 10 | package Shared is new Rx.Impl.Shared_Observer (Typed); 11 | 12 | use Typed.Conversions; 13 | 14 | type Runner is new Dispatchers.Runnable with record 15 | Thread : Schedulers.Thread; 16 | Pause : Duration; -- Repetitive period 17 | Value : Typed.D; -- Next value to emit 18 | Next : Ada.Calendar.Time; -- Reference for next deadline 19 | 20 | Child : Shared.Observer; -- Reduce copy stress with a shared observer across runnables 21 | end record; 22 | 23 | --------- 24 | -- Run -- 25 | --------- 26 | 27 | overriding procedure Run (R : Runner) is 28 | use Ada.Calendar; 29 | RW : Runner := R; 30 | begin 31 | RW.Child.On_Next (+R.Value); 32 | RW.Value := +Succ (+R.Value); 33 | RW.Next := R.Next + R.Pause; 34 | RW.Thread.Schedule (RW, RW.Next); 35 | exception 36 | when No_Longer_Subscribed => 37 | Debug.Log ("Interval runner: caught No_Longer_Subscribed", Debug.Note); 38 | when E : others => 39 | Typed.Defaults.Default_Error_Handler (RW.Child, E); 40 | end Run; 41 | 42 | type State is record 43 | First : Typed.D; 44 | Pause, 45 | First_Pause : Duration; 46 | Scheduler : Schedulers.Scheduler; 47 | end record; 48 | 49 | ------------------ 50 | -- On_Subscribe -- 51 | ------------------ 52 | 53 | procedure On_Subscribe (S : State; Observer : in out Typed.Observer) is 54 | use Ada.Calendar; 55 | R : constant Runner := Runner'(Thread => S.Scheduler.Get_Thread, 56 | Pause => S.Pause, 57 | Value => S.First, 58 | Next => Clock + S.First_Pause, 59 | Child => Shared.Create (Observer)); 60 | begin 61 | R.Thread.Schedule (R, Clock + S.First_Pause); 62 | end On_Subscribe; 63 | 64 | package Pre is new Src.Create (Typed); 65 | package Source is new Pre.With_State (State, On_Subscribe, Autocompletes => False); 66 | 67 | ------------ 68 | -- Create -- 69 | ------------ 70 | 71 | function Create 72 | (First : Typed.T; 73 | Period : Duration := 1.0; 74 | First_Pause : Duration := 0.0; 75 | Scheduler : Schedulers.Scheduler := Schedulers.Computation) 76 | return Typed.Observable 77 | is 78 | begin 79 | return Source.Create (State'(First => +First, 80 | Pause => Period, 81 | First_Pause => First_Pause, 82 | Scheduler => Scheduler)); 83 | end Create; 84 | 85 | end Rx.Src.Interval; 86 | -------------------------------------------------------------------------------- /src/body/rx-src-just.adb: -------------------------------------------------------------------------------- 1 | with Rx.Src.Create; 2 | 3 | package body Rx.Src.Just is 4 | 5 | procedure On_Subscribe (State : Typed.D; 6 | Observer : in out Typed.Observer) 7 | is 8 | begin 9 | Observer.On_Next (Typed.Type_Traits.To_Indefinite (State)); 10 | end On_Subscribe; 11 | 12 | package SrcCreate is new Src.Create (Typed); 13 | package Source is new SrcCreate.With_State (Typed.D, On_Subscribe); 14 | 15 | function Create (V : Typed.T) return Typed.Observable'Class is 16 | begin 17 | return Source.Create (Typed.Type_Traits.To_Definite (V)); 18 | end Create; 19 | 20 | end Rx.Src.Just; 21 | -------------------------------------------------------------------------------- /src/body/rx-src-ranges.adb: -------------------------------------------------------------------------------- 1 | with Rx.Errors; 2 | 3 | package body Rx.Src.Ranges is 4 | 5 | use Typed.Conversions; 6 | 7 | package Contracts renames Typed.Contracts; 8 | 9 | type Kinds is (Counter, Interval); 10 | 11 | type Observable (Mode : Kinds) is new Contracts.Observable with record 12 | Next : Typed.D; 13 | case Mode is 14 | when Counter => Remaining : Rx_Natural; 15 | when Interval => Last : Typed.D; 16 | end case; 17 | end record; 18 | 19 | overriding procedure Subscribe (This : in out Observable; Observer : in out Typed.Observer) is 20 | begin 21 | begin 22 | case This.Mode is 23 | when Counter => 24 | for I in 1 .. This.Remaining loop 25 | Observer.On_Next (+This.Next); 26 | This.Next := +Succ (+This.Next); 27 | end loop; 28 | when Interval => 29 | while +This.Next < +This.Last or else +This.Next = +This.Last loop 30 | Observer.On_Next (+This.Next); 31 | This.Next := +Succ (+This.Next); 32 | end loop; 33 | end case; 34 | exception 35 | when E : others => 36 | Observer.On_Error (Errors.Create (E)); 37 | end; 38 | 39 | Observer.On_Complete ; 40 | end Subscribe; 41 | 42 | ------------------- 43 | -- From_Count -- 44 | ------------------- 45 | 46 | function From_Count 47 | (First : Typed.T; 48 | Count : Rx_Natural) 49 | return Typed.Observable 50 | is 51 | use Typed.Type_Traits; 52 | begin 53 | return Observable'(Mode => Counter, Next => +First, Remaining => Count); 54 | end From_Count; 55 | 56 | -------------------- 57 | -- From_Slice -- 58 | -------------------- 59 | 60 | function From_Slice (First, Last : Typed.T) return Typed.Observable is 61 | begin 62 | return Observable'(Mode => Interval, Next => +First, Last => +Last); 63 | end From_Slice; 64 | 65 | end Rx.Src.Ranges; 66 | -------------------------------------------------------------------------------- /src/body/rx-src-start.adb: -------------------------------------------------------------------------------- 1 | with Rx.Src.Just; 2 | 3 | package body Rx.Src.Start is 4 | 5 | package RxJust is new Rx.Src.Just (Typed); 6 | 7 | ------------ 8 | -- Create -- 9 | ------------ 10 | 11 | function Create 12 | (Func : Typed.Actions.TFunc0'Class) 13 | return Typed.Observable 14 | is 15 | Actual : Typed.Actions.TFunc0'Class := Func; -- RW copy 16 | begin 17 | return RxJust.Create (Actual.Get); 18 | end Create; 19 | 20 | end Rx.Src.Start; 21 | -------------------------------------------------------------------------------- /src/body/rx-src-timer.adb: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | with Rx.Op.Limit; 3 | with Rx.Src.Interval; 4 | 5 | package body Rx.Src.Timer is 6 | 7 | function Dummy_Succ (V : Typed.T) return Typed.T is (V); 8 | 9 | package Operate is new Rx.Impl.Preservers (Typed); 10 | package RxInterval is new Rx.Src.Interval (Typed, Dummy_Succ); 11 | package RxLimit is new Rx.Op.Limit (Operate); 12 | 13 | ------------ 14 | -- Create -- 15 | ------------ 16 | 17 | function Create 18 | (V : Typed.T; 19 | After : Duration; 20 | Scheduler : Schedulers.Scheduler := Schedulers.Computation) 21 | return Typed.Observable 22 | is 23 | use Operate.Linkers; 24 | begin 25 | return 26 | RxInterval.Create (First => V, 27 | Period => 0.0, 28 | First_Pause => After, 29 | Scheduler => Scheduler) 30 | & RxLimit.Create (1); 31 | end Create; 32 | 33 | end Rx.Src.Timer; 34 | -------------------------------------------------------------------------------- /src/body/rx-subscriptions.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Subscriptions is 2 | 3 | ----------------- 4 | -- Unsubscribe -- 5 | ----------------- 6 | 7 | overriding procedure Unsubscribe (S : in out Subscription) is 8 | procedure Set (B : in out State) is 9 | begin 10 | B := Unsubscribed; 11 | end Set; 12 | begin 13 | if S.Is_Valid then 14 | S.Apply (Set'Access); 15 | else 16 | raise Program_Error with "Was never subscribed"; 17 | end if; 18 | end Unsubscribe; 19 | 20 | end Rx.Subscriptions; 21 | -------------------------------------------------------------------------------- /src/body/rx-tools-holders.adb: -------------------------------------------------------------------------------- 1 | with Ada.Unchecked_Deallocation; 2 | 3 | with Gnat.IO; use Gnat.IO; 4 | 5 | with Rx.Debug; 6 | 7 | package body Rx.Tools.Holders is 8 | 9 | function "+" (I : Indef) return Definite is 10 | begin 11 | return (Controlled with Actual => new Indef'(I)); 12 | end "+"; 13 | 14 | ---------- 15 | -- Hold -- 16 | ---------- 17 | 18 | procedure Hold (D : in out Definite; I : Indef) is 19 | begin 20 | if D.Actual /= null then 21 | D.Finalize; 22 | end if; 23 | D.Actual := new Indef'(I); 24 | end Hold; 25 | 26 | ---------------- 27 | -- Initialize -- 28 | ---------------- 29 | 30 | overriding procedure Initialize (D : in out Definite) is 31 | begin 32 | if D.Actual /= null then 33 | -- Put_Line ("initialize"); 34 | raise Program_Error; 35 | end if; 36 | end Initialize; 37 | 38 | ------------ 39 | -- Adjust -- 40 | ------------ 41 | 42 | overriding procedure Adjust (D : in out Definite) is 43 | begin 44 | if D.Actual /= null then 45 | D.Actual := new Indef'(D.Actual.all); 46 | end if; 47 | exception 48 | when others => 49 | Put_Line (Id & ": alloc exception (adjust)"); 50 | -- Rx.Debug.Print (E); 51 | raise; 52 | end Adjust; 53 | 54 | -------------- 55 | -- Finalize -- 56 | -------------- 57 | 58 | overriding procedure Finalize (D : in out Definite) is 59 | procedure Free is new Ada.Unchecked_Deallocation (Indef, Indef_Access); 60 | begin 61 | if D.Actual /= null then 62 | Free (D.Actual); 63 | end if; 64 | exception 65 | when E : others => 66 | Put_Line (Id & ": alloc exception (finalize)"); 67 | Rx.Debug.Print (E); 68 | raise; 69 | end Finalize; 70 | 71 | --------- 72 | -- Ref -- 73 | --------- 74 | 75 | function Ref (D : in out Definite) return Reference is 76 | begin 77 | return Reference'(Actual => D.Actual); 78 | end Ref; 79 | 80 | ---------- 81 | -- CRef -- 82 | ---------- 83 | 84 | function CRef (D : Definite) return Const_Ref is (Actual => D.Actual); 85 | 86 | end Rx.Tools.Holders; 87 | -------------------------------------------------------------------------------- /src/body/rx-tools-lazies.adb: -------------------------------------------------------------------------------- 1 | with Ada.Unchecked_Deallocation; 2 | 3 | package body Rx.Tools.Lazies is 4 | 5 | procedure Free is new Ada.Unchecked_Deallocation (Content, Ptr); 6 | 7 | --------- 8 | -- Get -- 9 | --------- 10 | 11 | function Get (This : in out Lazy) return Ptr is 12 | X : Ptr; 13 | begin 14 | This.Safe.Get (X); 15 | return X; 16 | end Get; 17 | 18 | ---------- 19 | -- Safe -- 20 | ---------- 21 | 22 | protected body Safes is 23 | 24 | --------- 25 | -- Get -- 26 | --------- 27 | 28 | procedure Get (X : in out Ptr) is 29 | begin 30 | if Instance /= null then 31 | X := Instance; 32 | else 33 | Instance := new Content; 34 | X := Instance; 35 | end if; 36 | end Get; 37 | 38 | ---------- 39 | -- Free -- 40 | ---------- 41 | 42 | procedure Free is 43 | begin 44 | Free (Instance); 45 | end Free; 46 | 47 | end Safes; 48 | 49 | -------------- 50 | -- Finalize -- 51 | -------------- 52 | 53 | overriding procedure Finalize (This : in out Lazy) is 54 | begin 55 | This.Safe.Free; 56 | end Finalize; 57 | 58 | end Rx.Tools.Lazies; 59 | -------------------------------------------------------------------------------- /src/body/rx-tools-semaphores.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | 3 | package body Rx.Tools.Semaphores is 4 | 5 | --------------- 6 | -- Reentrant -- 7 | --------------- 8 | 9 | protected body Reentrant is 10 | 11 | ------------- 12 | -- Release -- 13 | ------------- 14 | 15 | procedure Release is 16 | begin 17 | Count := Count - 1; 18 | Debug.Trace ("Releasing [count]" & Count'Img); 19 | end Release; 20 | 21 | ----------- 22 | -- Seize -- 23 | ----------- 24 | 25 | entry Seize when True is 26 | use Ada.Task_Identification; 27 | begin 28 | if Reentrant.Seize'Caller = Owner then 29 | Count := Count + 1; 30 | Debug.Trace ("Seizing [count]" & Count'Img & " @ " & Image (Owner)); 31 | else 32 | Debug.Trace ("Waiting [count]" & Count'Img & " @ " & Image (Reentrant.Seize'Caller)); 33 | requeue Wait with abort; 34 | end if; 35 | end Seize; 36 | 37 | ---------- 38 | -- Wait -- 39 | ---------- 40 | 41 | entry Wait when Count = 0 is 42 | use Ada.Task_Identification; 43 | begin 44 | Debug.Trace ("Seizing [wait] @ " & Image (Wait'Caller)); 45 | Count := 1; 46 | Owner := Wait'Caller; 47 | end Wait; 48 | 49 | end Reentrant; 50 | 51 | function Tamper is new Shared_Semaphores.Tamper; 52 | 53 | subtype Proxy is Shared_Semaphores.Proxy; 54 | 55 | ----------- 56 | -- Seize -- 57 | ----------- 58 | 59 | not overriding procedure Seize (This : in out Shared) is 60 | begin 61 | if not This.Fake then 62 | Debug.Trace ("outer seize " & This.Image); 63 | Tamper (Proxy (This)).Seize; 64 | end if; 65 | end Seize; 66 | 67 | ------------- 68 | -- Release -- 69 | ------------- 70 | 71 | not overriding procedure Release (This : in out Shared) is 72 | begin 73 | if not This.Fake then 74 | Debug.Trace ("outer release " & This.Image); 75 | Tamper (Proxy (This)).Release; 76 | end if; 77 | end Release; 78 | 79 | ---------------- 80 | -- Initialize -- 81 | ---------------- 82 | 83 | overriding procedure Initialize (This : in out Critical_Section) is 84 | begin 85 | if This.Mutex.Fake then 86 | null; 87 | elsif not This.Mutex.Is_Valid then 88 | raise Constraint_Error with "Uninitialized semaphore"; 89 | else 90 | This.Sem := This.Mutex.all; 91 | -- We make a local copy so that the semaphore exists until release, even if it is destroyen in the 92 | -- critical section 93 | This.Sem.Seize; 94 | end if; 95 | end Initialize; 96 | 97 | -------------- 98 | -- Finalize -- 99 | -------------- 100 | 101 | overriding procedure Finalize (This : in out Critical_Section) is 102 | begin 103 | if This.Sem.Is_Valid then 104 | This.Sem.Release; 105 | end if; 106 | end Finalize; 107 | 108 | end Rx.Tools.Semaphores; 109 | -------------------------------------------------------------------------------- /src/body/rx-traits-arrays.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Traits.Arrays is 2 | 3 | -------------- 4 | -- Builders -- 5 | -------------- 6 | 7 | use Typed.Conversions; 8 | 9 | ----------- 10 | -- Build -- 11 | ----------- 12 | 13 | function Build 14 | (V1 : Typed.T; 15 | More : Typed_Array := Empty_Array) 16 | return Typed_Array 17 | is 18 | begin 19 | return (Indexes'First => +V1) & More; 20 | end Build; 21 | 22 | ----------- 23 | -- Build -- 24 | ----------- 25 | 26 | function Build 27 | (V1, V2 : Typed.T; 28 | More : Typed_Array := Empty_Array) 29 | return Typed_Array 30 | is 31 | begin 32 | return (+V1, +V2) & More; 33 | end Build; 34 | 35 | ----------- 36 | -- Build -- 37 | ----------- 38 | 39 | function Build 40 | (V1, V2, V3 : Typed.T; 41 | More : Typed_Array := Empty_Array) 42 | return Typed_Array 43 | is 44 | begin 45 | return (+V1, +V2, +V3) & More; 46 | end Build; 47 | 48 | ----------- 49 | -- Build -- 50 | ----------- 51 | 52 | function Build 53 | (V1, V2, V3, V4 : Typed.T; 54 | More : Typed_Array := Empty_Array) 55 | return Typed_Array 56 | is 57 | begin 58 | return (+V1, +V2, +V3, +V4) & More; 59 | end Build; 60 | 61 | ----------- 62 | -- Build -- 63 | ----------- 64 | 65 | function Build 66 | (V1, V2, V3, V4, V5 : Typed.T; 67 | More : Typed_Array := Empty_Array) 68 | return Typed_Array 69 | is 70 | begin 71 | return (+V1, +V2, +V3, +V4, +V5) & More; 72 | end Build; 73 | 74 | ----------- 75 | -- Build -- 76 | ----------- 77 | 78 | function Build 79 | (V1, V2, V3, V4, V5, V6 : Typed.T; 80 | More : Typed_Array := Empty_Array) 81 | return Typed_Array 82 | is 83 | begin 84 | return (+V1, +V2, +V3, +V4, +V5, +V6) & More; 85 | end Build; 86 | 87 | end Rx.Traits.Arrays; 88 | -------------------------------------------------------------------------------- /src/bugs/b000.adb: -------------------------------------------------------------------------------- 1 | procedure B000 is 2 | 3 | package P is 4 | 5 | type Str_Holder is tagged private; 6 | 7 | function Create (S : String) return Str_Holder; 8 | 9 | type Reference (S : access String) is limited null record 10 | with Implicit_Dereference => S; 11 | 12 | function Ref (Str : Str_Holder) return Reference; 13 | 14 | private 15 | 16 | type Str_Ptr is access String; 17 | 18 | type Str_Holder is tagged record 19 | Ptr : Str_Ptr; 20 | end record; 21 | 22 | function Create (S : String) return Str_Holder is (Ptr => new String'(S)); 23 | 24 | function Ref (Str : Str_Holder) return Reference is (Reference'(S => Str.Ptr)); 25 | 26 | end P; 27 | 28 | S : constant P.Str_Holder := P.Create ("WTF"); 29 | 30 | procedure Long_Lived is 31 | begin 32 | for I in 1 .. 9_999_999 loop 33 | exit when S.Ref = "XXX"; 34 | end loop; 35 | end Long_Lived; 36 | 37 | begin 38 | Long_Lived; 39 | end B000; 40 | -------------------------------------------------------------------------------- /src/bugs/b001_tagged.adb: -------------------------------------------------------------------------------- 1 | procedure B001_Tagged is 2 | 3 | generic 4 | type X is private; 5 | package Untagged is 6 | 7 | type Y is new X; 8 | 9 | end Untagged; 10 | 11 | package Ok is new Untagged (Integer); 12 | 13 | type Void is tagged null record; 14 | 15 | package Err is new Untagged (Void); 16 | 17 | begin 18 | null; 19 | end B001_Tagged; 20 | -------------------------------------------------------------------------------- /src/bugs/b002_taskiface.adb: -------------------------------------------------------------------------------- 1 | -- with B002_Pkg; 2 | 3 | procedure B002_Taskiface is 4 | 5 | package Inner is 6 | 7 | type Some_Task is task interface; 8 | 9 | type Some_Ptr is access all Some_Task'Class; 10 | 11 | type Wrapper (Ptr : Some_Ptr) is limited private; 12 | 13 | private 14 | 15 | type Wrapper (Ptr : Some_Ptr) is limited null record; 16 | 17 | end Inner; 18 | 19 | task type T is new Inner.Some_Task with end T; 20 | 21 | task body T is 22 | S : Inner.Some_Ptr := T'Unchecked_Access; 23 | W : Inner.Wrapper (T'Unchecked_Access); 24 | begin 25 | if T'Terminated then null; end if; 26 | -- if W.Ptr.all'Terminated then null; end if; -- Likewise fails 27 | if S.all'Terminated then null; end if; 28 | end T; 29 | 30 | begin 31 | null; 32 | end B002_Taskiface; 33 | -------------------------------------------------------------------------------- /src/bugs/b003_taskleak.adb: -------------------------------------------------------------------------------- 1 | with Ada.Finalization; 2 | with Ada.Unchecked_Deallocation; 3 | 4 | procedure B003_Taskleak is 5 | 6 | package Inner is 7 | 8 | type Some_Task is task interface; 9 | type Some_Ptr is access all Some_Task'Class; 10 | 11 | type Wrapper (Ptr : Some_Ptr) is limited private; 12 | 13 | task type T is new Inner.Some_Task with end T; 14 | 15 | private 16 | 17 | type Wrapper (Ptr : Some_Ptr) is new Ada.Finalization.Limited_Controlled with null record; 18 | 19 | overriding procedure Initialize (W : in out Wrapper); 20 | 21 | end Inner; 22 | 23 | package body Inner is 24 | 25 | overriding procedure Initialize (W : in out Wrapper) is 26 | procedure Free is new Ada.Unchecked_Deallocation (Some_Task'Class, Some_Ptr); 27 | Ptr : Some_Ptr := W.Ptr; 28 | begin 29 | Free (Ptr); 30 | end Initialize; 31 | 32 | task body T is 33 | W : Inner.Wrapper (T'Unchecked_Access); 34 | begin 35 | delay 1.0; 36 | end T; 37 | 38 | end Inner; 39 | 40 | procedure Leak is 41 | Ptr : Inner.Some_Ptr := new Inner.T; 42 | begin 43 | null; 44 | end Leak; 45 | 46 | begin 47 | for I in 1 .. 99 loop 48 | Leak; 49 | end loop; 50 | end B003_Taskleak; 51 | -------------------------------------------------------------------------------- /src/bugs/b004_refleak.adb: -------------------------------------------------------------------------------- 1 | procedure B004_Refleak is 2 | 3 | package P is 4 | 5 | type Str_Holder is tagged private; 6 | -- IRL this would be a controlled type with proper allocation/deallocation of the held type 7 | 8 | function Create (S : String) return Str_Holder; 9 | 10 | type Reference (S : access String) is limited null record 11 | with Implicit_Dereference => S; 12 | 13 | function Ref (Str : Str_Holder) return Reference; 14 | 15 | private 16 | 17 | type Str_Ptr is access String; 18 | 19 | type Str_Holder is tagged record 20 | Ptr : Str_Ptr; 21 | end record; 22 | 23 | function Create (S : String) return Str_Holder is (Ptr => new String'(S)); 24 | 25 | function Ref (Str : Str_Holder) return Reference is (Reference'(S => Str.Ptr)); 26 | 27 | end P; 28 | 29 | S : constant P.Str_Holder := P.Create ("WTF"); 30 | 31 | procedure Long_Lived is 32 | begin 33 | for I in 1 .. 9_999_999 loop 34 | exit when S.Ref = "XXX"; 35 | end loop; 36 | end Long_Lived; 37 | 38 | begin 39 | Long_Lived; 40 | end B004_Refleak; 41 | -------------------------------------------------------------------------------- /src/bugs/finalize_leak.adb: -------------------------------------------------------------------------------- 1 | with Ada.Finalization; use Ada.Finalization; 2 | with Ada.Unchecked_Deallocation; 3 | with Ada.Text_Io; use Ada.Text_Io; 4 | 5 | procedure Finalize_Leak is 6 | generic 7 | package P is 8 | 9 | type Leftie is interface; 10 | type Rightie is interface; 11 | 12 | type Left_Access is access Leftie'Class; 13 | type Holder is new Controlled with record 14 | Held : Left_Access; 15 | end record; 16 | overriding procedure Adjust (Op : in out Holder); 17 | overriding procedure Finalize (Op : in out Holder); 18 | function Hold (L : Leftie'Class) return Holder 19 | is (Holder'(Controlled with Held => new Leftie'Class'(L))); 20 | 21 | type Subscriber is new Rightie with record 22 | Parent : Holder; 23 | end record; 24 | procedure Set_Parent (S : in out Subscriber; Parent : Leftie'Class); 25 | 26 | type Operator is new Subscriber and Leftie with null record; 27 | 28 | function "&" (L : Leftie'Class; R : Operator'Class) return Operator'Class; 29 | 30 | type Nop is new Operator with null record; 31 | 32 | function N return Operator'Class is (Nop'(others => <>)); 33 | 34 | end P; 35 | 36 | package body P is 37 | overriding procedure Adjust (Op : in out Holder) is 38 | begin 39 | if Op.Held /= null then 40 | Put_Line ("adjust"); 41 | Op.Held := new Leftie'Class'(Op.Held.all); 42 | end if; 43 | end Adjust; 44 | overriding procedure Finalize (Op : in out Holder) is 45 | procedure Free is new Ada.Unchecked_Deallocation (Leftie'Class, Left_Access); 46 | begin 47 | Put_Line ("finalize"); 48 | Free (Op.Held); 49 | end Finalize; 50 | 51 | procedure Set_Parent (S : in out Subscriber; Parent : Leftie'Class) is 52 | begin 53 | S.Parent := Hold (Parent); 54 | end Set_Parent; 55 | 56 | function "&" (L : Leftie'Class; R : Operator'Class) return Operator'Class is 57 | A : Operator'Class := R; 58 | begin 59 | A.Set_Parent (L); 60 | return A; 61 | end "&"; 62 | end P; 63 | 64 | package PP is new P; use PP; 65 | 66 | begin 67 | for I in 1 .. 1 loop 68 | Put_Line ("---8<---"); 69 | declare 70 | Leak : Leftie'Class := N & N with Unreferenced; 71 | begin 72 | null; 73 | end; 74 | Put_Line ("--->8---"); 75 | end loop; 76 | Put_Line ("END"); 77 | -- Why are there finalizations past this point? 78 | end Finalize_Leak; 79 | -------------------------------------------------------------------------------- /src/bugs/holder_leak.adb: -------------------------------------------------------------------------------- 1 | with Ada.Containers.Indefinite_Holders; 2 | with Ada.Text_IO; use Ada.Text_IO; 3 | 4 | procedure Holder_Leak is 5 | use Ada.Containers; 6 | type Indef is array (Integer range <>) of Integer; 7 | package Holders is new Indefinite_Holders (Indef); 8 | type Def is new Holders.Holder with null record; 9 | 10 | -- This wrapper type is necessary for the leak to manifest 11 | type Outer is record 12 | Inner : Def; 13 | end record; 14 | 15 | procedure Eat (O : Outer) is 16 | begin 17 | for I of O.Inner.Constant_Reference loop 18 | -- Using .Element instead there is no leak 19 | Put_Line (I'Img); 20 | end loop; 21 | end Eat; 22 | 23 | begin 24 | for I in 1 .. 666 loop 25 | Eat ((Inner => To_Holder ((1, 2, 3, 4, 5)))); 26 | end loop; 27 | end Holder_Leak; 28 | -------------------------------------------------------------------------------- /src/bugs/precedence.adb: -------------------------------------------------------------------------------- 1 | procedure Precedence is 2 | 3 | generic 4 | package Nested is 5 | 6 | type Object is tagged null record; 7 | 8 | procedure Method (O : Object) is null; 9 | 10 | end Nested; 11 | 12 | package Nest is new Nested; 13 | 14 | function Op (X, Y : Integer) return Nest.Object'Class is 15 | pragma Unreferenced (X, Y); 16 | begin 17 | return Nest.Object'(null record); 18 | end Op; 19 | 20 | function "&" (X, Y : Integer) return Nest.Object'Class renames Op; 21 | 22 | N : constant Nest.Object'Class := Op (1, 2); 23 | M : constant Nest.Object'Class := 1 & 2; 24 | 25 | begin 26 | N.Method; -- Of course this works 27 | M.Method; 28 | 29 | Op (1, 2).Method; -- Fine 30 | "&" (1, 2).Method; -- Fine too 31 | --(1 & 2).Method; -- Error: statement expected (gpl2015/16) 32 | end Precedence; 33 | -------------------------------------------------------------------------------- /src/bugs/rx-bugs-op_leak.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | with Rx.Std; use Rx.Std; 3 | 4 | procedure Rx.Bugs.Op_Leak is 5 | use Integers; 6 | begin 7 | for I in 1 .. 3 loop 8 | Put_Line ("---8<---"); 9 | declare 10 | Leak : Integers.Observable := 11 | No_Op 12 | & 13 | No_Op; 14 | pragma Unreferenced (Leak); 15 | begin 16 | null; 17 | end; 18 | Put_Line ("--->8---"); 19 | end loop; 20 | 21 | Put_Line ("END"); 22 | 23 | -- Dump; 24 | end Rx.Bugs.Op_Leak; 25 | -------------------------------------------------------------------------------- /src/bugs/rx-bugs-support.adb: -------------------------------------------------------------------------------- 1 | -- with Rx.Debug; use Rx.Debug; 2 | 3 | package body Rx.Bugs.Support is 4 | 5 | end Rx.Bugs.Support; 6 | -------------------------------------------------------------------------------- /src/bugs/rx-bugs-support.ads: -------------------------------------------------------------------------------- 1 | package Rx.Bugs.Support with Elaborate_Body is 2 | 3 | end Rx.Bugs.Support; 4 | -------------------------------------------------------------------------------- /src/bugs/rx-bugs-testbed.adb: -------------------------------------------------------------------------------- 1 | with Rx.Bugs.Support; 2 | with Rx.Debug; use Rx.Debug; 3 | with Rx.Debug.Observers; 4 | with Rx.Tools.Semaphores; 5 | with Rx.Std; use Rx.Std; 6 | with Rx.Schedulers; 7 | with Rx.Subscriptions; 8 | 9 | procedure Rx.Bugs.Testbed is 10 | use Integers; 11 | 12 | package Checkers is new Debug.Observers (Integers.Typed, 0, Image); 13 | 14 | task type Dumper (Dumpee : access Integers.Sink); 15 | 16 | type Dumper_Access is access all Dumper; 17 | 18 | task body Dumper is 19 | begin 20 | for I in 1 .. 1000 loop 21 | Dumpee.On_Next (0); 22 | end loop; 23 | end Dumper; 24 | 25 | procedure Test_001_Shared_Leak with Unreferenced is 26 | -- There should be no leak here 27 | S : Subscription; 28 | pragma Unreferenced (S); 29 | begin 30 | S := 31 | From ((1, 2, 3, 4, 5)) & 32 | Limit (3) & 33 | Observe_On (Schedulers.Computation) & 34 | Subscribe (Debug.Put_Line'Access); 35 | end Test_001_Shared_Leak; 36 | 37 | procedure Test_002_Blocking with Unreferenced is 38 | -- There should be no blocking operation exception here 39 | Sem : aliased Tools.Semaphores.Shared := Tools.Semaphores.Create_Reentrant; 40 | Crit : Tools.Semaphores.Critical_Section (Sem'Access) with Unreferenced; 41 | begin 42 | null; 43 | end Test_002_Blocking; 44 | 45 | Dumpee : aliased Integers.Sink := Checkers.Subscribe_Count_Printer; 46 | 47 | procedure Test_003_Serialize with Unreferenced is 48 | -- Check for serialize efectiveness 49 | begin 50 | declare 51 | Dumpers : array (1 .. 10) of Dumper_Access := 52 | (others => new Dumper (Dumpee => Dumpee'Access)) 53 | with Unreferenced; 54 | begin 55 | null; 56 | end; 57 | -- After tasks completion, print: 58 | Dumpee.On_Complete ; 59 | end Test_003_Serialize; 60 | 61 | begin 62 | for I in 1 .. 99 loop 63 | null; 64 | end loop; 65 | 66 | Put_Line ("END"); 67 | end Rx.Bugs.Testbed; 68 | -------------------------------------------------------------------------------- /src/bugs/rx-bugs.ads: -------------------------------------------------------------------------------- 1 | package Rx.Bugs is 2 | 3 | pragma Pure; 4 | 5 | end Rx.Bugs; 6 | -------------------------------------------------------------------------------- /src/main/rx-devel-main.adb: -------------------------------------------------------------------------------- 1 | procedure Rx.Devel.Main is 2 | begin 3 | Rx.Devel.Run; 4 | end Rx.Devel.Main; 5 | -------------------------------------------------------------------------------- /src/main/rx-devel.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; 2 | -- with Rx.Debug.Observers; 3 | with Rx.Std; use Rx.Std; 4 | with Rx.Subscriptions; 5 | 6 | package body Rx.Devel is 7 | 8 | use Rx.Std.Integers; 9 | use Rx.Std.Integer_To_String; 10 | use Rx.Std.Strings; 11 | 12 | -- package Ints renames Std.Integers; 13 | -- package IntChecker is new Debug.Observers (Std.Integers.Typed, 0, Rx_Integer'Image); use IntChecker; 14 | 15 | -- function Selfsum (I : Rx_Integer) return Integers.Observable'Class is (Just (I + I)); 16 | 17 | -- Inf : Integer_To_String.Typed.Actions.Inflater1 := AAA'Access; 18 | 19 | -- function Below (I : Rx_Integer) return Integers.Observable'Class is 20 | -- (if I <= 1 21 | -- then Integers.Empty 22 | -- else Numeric.Integers.Range_Slice (1, I - 1)); 23 | 24 | function Image (I : Rx_Integer) return Strings.Observable'Class is 25 | (Just (I'Img)); 26 | 27 | procedure Run is 28 | Subs : Rx.Subscriptions.Subscription; 29 | begin 30 | Debug.Trace ("starting"); 31 | 32 | Subs := 33 | From ((1, 2, 3, 4, 5)) 34 | -- & Integer_To_String.Flat_Map (No_Op 35 | -- & Std.Casts.To_String) 36 | & Flat_Map (Image'Access) 37 | & Subscribe; 38 | 39 | while Subs.Is_Subscribed loop 40 | delay 0.1; 41 | end loop; 42 | end Run; 43 | 44 | end Rx.Devel; 45 | -------------------------------------------------------------------------------- /src/main/rx-devel.ads: -------------------------------------------------------------------------------- 1 | package Rx.Devel is 2 | 3 | procedure Run; 4 | 5 | end Rx.Devel; 6 | -------------------------------------------------------------------------------- /src/main/rx-devsupport.adb: -------------------------------------------------------------------------------- 1 | package body Rx.Devsupport is 2 | 3 | ------------- 4 | -- Blah123 -- 5 | ------------- 6 | 7 | procedure Blah123 (Observer : in out Std.Integers.Typed.Observer'Class) is 8 | begin 9 | Observer.On_Next (1); 10 | delay 0.2; 11 | Observer.On_Next (2); 12 | delay 0.2; 13 | Observer.On_Next (3); 14 | Observer.On_Next (4); 15 | Observer.On_Next (5); 16 | Observer.On_Complete ; 17 | end Blah123; 18 | 19 | end Rx.Devsupport; 20 | -------------------------------------------------------------------------------- /src/main/rx-devsupport.ads: -------------------------------------------------------------------------------- 1 | with Rx.Debug.Observers; 2 | with Rx.Src.Create; 3 | with Rx.Std; 4 | 5 | package Rx.Devsupport is 6 | 7 | -- For things that must be at library level 8 | 9 | package Create is new Src.Create (Std.Integers.Typed); 10 | package IntChecker is new Debug.Observers (Std.Integers.Typed, 0, Rx_Integer'Image); 11 | 12 | procedure Blah123 (Observer : in out Std.Integers.Typed.Observer'Class); 13 | 14 | end Rx.Devsupport; 15 | -------------------------------------------------------------------------------- /src/main/rx-examples-advanced.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | with Rx.Schedulers; 3 | with Rx.Std; use Rx.Std; 4 | 5 | procedure Rx.Examples.Advanced is 6 | use Integers; 7 | use Strings; 8 | -- use String_To_Integer; 9 | use Integer_To_String; 10 | -- use Numeric.Integers; 11 | 12 | 13 | begin 14 | Debug.Put_Line ("Merge example 1 (merged items)"); 15 | Sub := 16 | From ((1, 2, 3)) 17 | & Merge_With (From ((4, 5, 6))) 18 | & Std.Casts.To_String 19 | & Subscribe (Debug.Put_Line'Access); 20 | 21 | Debug.Put_Line ("Merge example (merged count)"); 22 | Sub := 23 | From ((1, 2, 3)) 24 | & Merge_With (From ((4, 5, 6))) 25 | & Numeric.Integers.Count 26 | & Std.Casts.To_String 27 | & Subscribe (Debug.Put_Line'Access); 28 | 29 | Debug.Put_Line ("Merge example (racing)"); 30 | Sub := Interval (First => 1000, Period => 0.001) 31 | & Observe_On (Schedulers.New_Thread) 32 | & Limit (100) 33 | & Merge_With (Interval (First => 2000, Period => 0.001) 34 | & Limit (100) 35 | & Observe_On (Schedulers.New_Thread)) 36 | & Std.Casts.To_String 37 | & Subscribe (Debug.Put_Line'Access); 38 | 39 | while Sub.Is_Subscribed loop 40 | delay 0.1; 41 | end loop; 42 | 43 | Debug.Put_Line ("Done."); 44 | exception 45 | when E : others => 46 | Debug.Print (E); 47 | end Rx.Examples.Advanced; 48 | -------------------------------------------------------------------------------- /src/main/rx-examples-basic.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | with Rx.Std; use Rx.Std; 3 | 4 | procedure Rx.Examples.Basic is 5 | use Integers; 6 | use Strings; 7 | use String_To_Integer; 8 | use Integer_To_String; 9 | use Numeric.Integers; 10 | 11 | 12 | procedure Custom_Src_1 (Observer : in out Integers.Typed.Observer) is 13 | begin 14 | Observer.On_Next (7); 15 | Observer.On_Next (8); 16 | Observer.On_Next (9); 17 | Observer.On_Complete ; 18 | end Custom_Src_1; 19 | 20 | begin 21 | Debug.Put_Line ("Just example"); 22 | Sub := 23 | Just ("Hello, world!") & 24 | Map (Length'Access) & 25 | Map (Image'Access) & 26 | Map (Length'Access) & 27 | Subscribe (Debug.Put_Line'Access); 28 | -- This should print " 3": 29 | -- "Hello, world!" --> 13 --> " 13" --> 3 --> Integer'Image (3) 30 | 31 | Debug.Put_Line ("From_Array example"); 32 | Sub := 33 | Integers.From ((5, 4, 3, 2, 1)) & 34 | Subscribe (Debug.Put_Line'Access); 35 | 36 | Debug.Put_Line ("Count example"); 37 | Sub := 38 | Integers.From ((0, 1, 2, 3)) & 39 | Count (First => 0) & 40 | Subscribe (Debug.Put_Line'Access); 41 | 42 | Debug.Put_Line ("Count reset example"); 43 | declare 44 | Ob : constant Integers.Observable := 45 | Integers.From ((0, 1, 2, 3)) 46 | & Count (First => 0); 47 | begin 48 | Sub := Ob & Subscribe (Put_Line'Access); -- Must both output 4 49 | Sub := Ob & Subscribe (Put_Line'Access); -- Must both output 4 50 | end; 51 | 52 | Debug.Put_Line ("Custom observable example"); 53 | Sub := 54 | Create (Custom_Src_1'Access) & 55 | Subscribe (Put_Line'Access); 56 | 57 | Debug.Put_Line ("Custom observable with closure example"); 58 | -- I think this must go down in flames if the scope is outlived by the chain, with some latency inducing operator 59 | -- Since there's no accessibility check kicking in, I guess this is a bug in Gnat and I should use a 60 | -- named access type in Rx.Src.Create. 61 | -- TODO: keep an eye on it (Issue #18) 62 | declare 63 | procedure Custom_Src_2 (Observer : in out Integers.Typed.Observer) is 64 | begin 65 | Observer.On_Next (4); 66 | Observer.On_Next (5); 67 | Observer.On_Next (6); 68 | Observer.On_Complete ; 69 | end Custom_Src_2; 70 | begin 71 | Sub := 72 | Create (Custom_Src_2'Access) & 73 | Subscribe (Put_Line'Access); 74 | end; 75 | 76 | exception 77 | when E : others => 78 | Debug.Print (E); 79 | end Rx.Examples.Basic; 80 | -------------------------------------------------------------------------------- /src/main/rx-examples-misc.adb: -------------------------------------------------------------------------------- 1 | with Rx.Schedulers; 2 | with Rx.Std; use Rx.Std; 3 | 4 | procedure Rx.Examples.Misc is 5 | use Integers.Linkers; 6 | use Strings.Linkers; 7 | begin 8 | Integers.Subscribe 9 | (All_Positives (Count => 999999) 10 | & 11 | Integers.Subscribe_On (Schedulers.IO) 12 | & 13 | Images.Integers.Print (With_Timestamp => False)); 14 | 15 | Strings.Subscribe 16 | (All_Printable_Strings (Initial => "", Count => 999999) 17 | & 18 | Strings.Subscribe_On (Schedulers.IO) 19 | & 20 | Images.Strings.Print (With_Timestamp => False)); 21 | end Rx.Examples.Misc; 22 | -------------------------------------------------------------------------------- /src/main/rx-examples-tests.adb: -------------------------------------------------------------------------------- 1 | with GNAT.Exception_Traces; 2 | 3 | with Rx.Tests; 4 | 5 | procedure Rx.Examples.Tests is 6 | begin 7 | GNAT.Exception_Traces.Trace_On (GNAT.Exception_Traces.Unhandled_Raise); 8 | -- GNAT.Exception_Traces.Trace_On (GNAT.Exception_Traces.Every_Raise); 9 | -- Might be useful for debugging 10 | 11 | pragma Assert (Rx.Tests.Misc_Tests); 12 | pragma Assert (Rx.Tests.Subscriptions); 13 | pragma Assert (Rx.Tests.Sources); 14 | pragma Assert (Rx.Tests.Operators); 15 | 16 | delay 2.0; -- Wait for watchdogs 17 | end Rx.Examples.Tests; 18 | -------------------------------------------------------------------------------- /src/main/rx-examples-threading.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | with Rx.Std; use Rx.Std; 3 | with Rx.Schedulers; 4 | with Rx.Schedulers.Pools; 5 | 6 | procedure Rx.Examples.Threading is 7 | use Integers; 8 | -- use Strings; 9 | -- use Integer_To_String; 10 | -- use String_To_Integer; 11 | 12 | Custom_Pool : Schedulers.Pools.Pool := Schedulers.Pools.Create (Size => 2, Name => "Custom"); 13 | 14 | function Custom_Idle return Schedulers.Thread is (Custom_Pool.Get_Idle); 15 | function Custom_Next return Schedulers.Thread is (Custom_Pool.Get_Next); 16 | 17 | procedure Finish is 18 | begin 19 | Debug.Put_Line ("Shutting down..."); 20 | end Finish; 21 | 22 | begin 23 | Sub := 24 | Std.Interval 25 | & Limit (5) 26 | & Print 27 | & Subscribe_On (Schedulers.IO) 28 | & Observe_On (Schedulers.Idle_Thread) 29 | & Print 30 | & Observe_On (Schedulers.New_Thread) 31 | & Print 32 | & Observe_On (Schedulers.Computation) 33 | & Print 34 | & Observe_On (Schedulers.To_Scheduler (Custom_Next'Unrestricted_Access)) 35 | & Print 36 | & Observe_On (Schedulers.To_Scheduler (Custom_Next'Unrestricted_Access)) 37 | & Print 38 | & Observe_On (Schedulers.To_Scheduler (Custom_Idle'Unrestricted_Access)) 39 | & Print 40 | & Subscribe (On_Next => Put_Line'Access, 41 | On_Complete => Finish'Unrestricted_Access); 42 | -- Regular accesses would suffice at library level 43 | 44 | exception 45 | when E : others => 46 | Debug.Print (E); 47 | end Rx.Examples.Threading; 48 | -------------------------------------------------------------------------------- /src/main/rx-examples.ads: -------------------------------------------------------------------------------- 1 | with Rx.Subscriptions; 2 | 3 | package Rx.Examples is 4 | 5 | function Length (S : Rx_String) return Rx_Integer is (S'Length); 6 | function Image (I : Rx_Integer) return Rx_String is (I'Img); 7 | function Inc (I : Rx_Integer) return Rx_Integer is (I+1); 8 | 9 | Nosub : Subscriptions.No_Subscription; 10 | Sub : Subscriptions.Subscription; 11 | 12 | -- Finally, to increase ambiguity: 13 | -- package Chars is new Rx.Definites (Character); -- THIS LINE BREAKS SOMETHING 14 | 15 | type Intarr is array (Rx_Integer range <>) of Rx_Integer; 16 | 17 | 18 | end Rx.Examples; 19 | -------------------------------------------------------------------------------- /src/main/rx-jsa2019.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | With Rx.Schedulers; 3 | with Rx.Std; use Rx.Std; 4 | with Rx.Subscriptions; 5 | 6 | with GNAT.String_Hash; 7 | 8 | package body Rx.JSA2019 is 9 | 10 | use Integers; 11 | use Integer_To_String; 12 | use String_To_Integer; 13 | 14 | type Hashes is mod 2 ** 32; 15 | 16 | function Modular_Hash is new GNAT.String_Hash.Hash (Character, Rx_String, Hashes); 17 | 18 | function String_Hash (S : String) return Rx_Integer is (Rx_Integer (Modular_Hash (S))); 19 | 20 | function Image (I : Rx_Integer) return String is (Rx_Integer'Image (I)); 21 | 22 | S : constant Subscription := 23 | Interval (First => 1, Period => 1.0) 24 | -- The RxAda Interval observable uses Duration as the time unit, and uses Ada tasks to implement Rx threads 25 | & Observe_On (Schedulers.Computation) 26 | -- Switch to a computation task 27 | & Map (Image'Access) 28 | -- Function that takes an Integer and returns its String image 29 | & Map (String_Hash'Access) 30 | -- E.g. instance of System.String_Hash 31 | & Observe_On (Schedulers.IO) 32 | -- Switch to an Input/Output thread 33 | & Subscribe (Put_Line'Access) with Unreferenced; 34 | 35 | end Rx.JSA2019; 36 | -------------------------------------------------------------------------------- /src/main/rx-jsa2019.ads: -------------------------------------------------------------------------------- 1 | package Rx.JSA2019 with Elaborate_Body is 2 | end Rx.JSA2019; 3 | -------------------------------------------------------------------------------- /src/main/rx-rst2017.adb: -------------------------------------------------------------------------------- 1 | with Rx.Debug; use Rx.Debug; 2 | With Rx.Schedulers; 3 | with Rx.Std; use Rx.Std; 4 | with Rx.Subscriptions; 5 | 6 | with GNAT.String_Hash; 7 | 8 | package body Rx.RST2017 is 9 | 10 | use Integers; 11 | use Integer_To_String; 12 | use String_To_Integer; 13 | 14 | type Hashes is mod 2 ** 32; 15 | 16 | function Modular_Hash is new GNAT.String_Hash.Hash (Character, Rx_String, Hashes); 17 | 18 | function String_Hash (S : String) return Rx_Integer is (Rx_Integer (Modular_Hash (S))); 19 | 20 | function Image (I : Rx_Integer) return String is (Rx_Integer'Image (I)); 21 | 22 | S : constant Subscription := 23 | Interval (First => 1, Period => 1.0) & 24 | -- The RxAda Interval observable uses Duration as the time unit, and uses Ada tasks to implement Rx threads 25 | Observe_On (Schedulers.Computation) & 26 | -- Switch to a computation task 27 | Map (Image'Access) & 28 | -- Function that takes an Integer and returns its String image 29 | Map (String_Hash'Access) & 30 | -- E.g. instance of System.String_Hash 31 | Observe_On (Schedulers.IO) & 32 | -- Switch to an Input/Output thread 33 | Subscribe (Put_Line'Access) with Unreferenced; 34 | 35 | end Rx.RST2017; 36 | -------------------------------------------------------------------------------- /src/main/rx-rst2017.ads: -------------------------------------------------------------------------------- 1 | package Rx.RST2017 with Elaborate_Body is 2 | end Rx.RST2017; 3 | -------------------------------------------------------------------------------- /src/priv/rx-debug-heavy.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | 3 | with Gnat.Debug_Pools; 4 | 5 | package Rx.Debug.Heavy is 6 | 7 | -- For heavyweight non-preelaborable debugging 8 | 9 | pragma Elaborate_Body; 10 | 11 | procedure Backtrace (E : Ada.Exceptions.Exception_Occurrence); 12 | 13 | procedure Current_Backtrace (Bailout : Boolean := False; 14 | Exit_Code : Integer := 1); 15 | -- Print backtrace at point of call 16 | -- Optionally exit with exit code 17 | 18 | -- Memory inspection 19 | Debug_Pool : Gnat.Debug_Pools.Debug_Pool; 20 | procedure Dump; 21 | 22 | end Rx.Debug.Heavy; 23 | -------------------------------------------------------------------------------- /src/priv/rx-debug-observers.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | Default_T : Typed.T; 6 | with function Image (V : Typed.T) return String is <>; 7 | package Rx.Debug.Observers is 8 | 9 | -- Observer classes with a precise behaviour for testing 10 | 11 | function Subscribe_Checker 12 | (Name : String; 13 | Do_Count : Boolean := False; 14 | Ok_Count : Natural := 0; 15 | Do_First : Boolean := False; 16 | Ok_First : Typed.T := Default_T; 17 | Do_Last : Boolean := False; 18 | Ok_Last : Typed.T := Default_T; 19 | Do_Watch : Boolean := True; 20 | Period : Duration:= 1.0) return Typed.Sink 21 | with Pre => Do_Count or Do_First or Do_Last; 22 | 23 | function Subscribe 24 | (Name : String; 25 | Do_Count : Boolean := False; 26 | Ok_Count : Natural := 0; 27 | Do_First : Boolean := False; 28 | Ok_First : Typed.T := Default_T; 29 | Do_Last : Boolean := False; 30 | Ok_Last : Typed.T := Default_T; 31 | Do_Watch : Boolean := True; 32 | Period : Duration:= 1.0) return Typed.Sink 33 | renames Subscribe_Checker; 34 | 35 | function Subscribe_Count_Printer return Typed.Sink; 36 | -- Counts items seen and prints them, counting in both thread safe/unsafe way 37 | 38 | end Rx.Debug.Observers; 39 | -------------------------------------------------------------------------------- /src/priv/rx-debug.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | with Ada.Tags; 3 | 4 | with GNAT.IO; 5 | with GNAT.Source_Info; 6 | 7 | private with Ada.Strings; 8 | private with Ada.Strings.Fixed; 9 | 10 | package Rx.Debug is 11 | 12 | pragma Preelaborate; 13 | 14 | type Levels is (Impl, -- Implementation detail, for debugging 15 | Note, -- Highly chatty 16 | Info, -- Out-of-usual 17 | Warn, -- Shouldn't happen but not critical (?) 18 | Error -- Something is definitely not working as expected 19 | ); 20 | 21 | Level : constant Levels := Info; 22 | -- Minimum level a message has to have for it to be printed 23 | 24 | Serialize_Trace : constant Boolean := True; 25 | -- This introduces a protected call, so use only for debugging purposes! 26 | 27 | procedure Log (S : String; Level : Levels); -- Prints S if above configured level 28 | 29 | procedure Trace (S : String; Prefix : String := GNAT.Source_Info.Source_Location); 30 | -- Log at Impl level 31 | 32 | procedure Trace (E : Ada.Exceptions.Exception_Occurrence; 33 | Msg : String); 34 | 35 | procedure Put_Line (I : Rx_Integer); 36 | procedure Put_Line (S : String) renames Gnat.IO.Put_Line; 37 | 38 | function Trim (S : String) return String; 39 | 40 | function Image (I : Rx_Integer) return String is (Rx_Integer'Image (I)); 41 | function Image (T : Ada.Tags.Tag) return String renames Ada.Tags.Expanded_Name; 42 | 43 | procedure Print (E : Ada.Exceptions.Exception_Occurrence); 44 | 45 | procedure Report (E : Ada.Exceptions.Exception_Occurrence; 46 | Msg : String; 47 | Level : Levels := Error; 48 | Reraise : Boolean := False); 49 | -- Prints Msg at level Level, prints the exception and optionally re-raises 50 | 51 | -- Early termination 52 | procedure Bailout (Exit_Code : Integer := 0); 53 | 54 | private 55 | 56 | function Trim (S : String) return String is (Ada.Strings.Fixed.Trim (S, Ada.Strings.Both)); 57 | 58 | end Rx.Debug; 59 | -------------------------------------------------------------------------------- /src/priv/rx-dispatchers-immediate.ads: -------------------------------------------------------------------------------- 1 | package Rx.Dispatchers.Immediate is 2 | 3 | use type Ada.Calendar.Time; 4 | 5 | type Dispatcher is limited new Dispatchers.Dispatcher with private; 6 | 7 | -- Schedule a code to be run at a certain point from now, in a certain Dispatcher (thread) 8 | overriding 9 | procedure Schedule (Where : in out Dispatcher; 10 | What : Runnable'Class; 11 | Time : Ada.Calendar.Time := Ada.Calendar.Clock); 12 | -- Providing a future time in this scheduler will result in Constraint_Error 13 | 14 | private 15 | 16 | type Dispatcher is limited new Dispatchers.Dispatcher with null record; 17 | 18 | end Rx.Dispatchers.Immediate; 19 | -------------------------------------------------------------------------------- /src/priv/rx-dispatchers-pools.ads: -------------------------------------------------------------------------------- 1 | with Rx.Dispatchers.Single; 2 | 3 | private with Ada.Containers; 4 | private with Ada.Containers.Vectors; 5 | private with Ada.Finalization; 6 | 7 | package Rx.Dispatchers.Pools is 8 | 9 | type String_Access is access all String; 10 | 11 | type Pool (Initial_Size : Positive := 8; Name : String_Access := new String'("anonymous")) 12 | is tagged limited private; 13 | 14 | function Get (From : in out Pool; Reuse : Boolean := False) return Single.Ptr; 15 | -- In round-robin fashion 16 | -- If Reuse and last returned thread is idle, return it again 17 | 18 | function Curr_Or_Next (From : in out Pool) return Single.Ptr is (From.Get (Reuse => True)); 19 | -- Return current in pool if idle, or next one regardless of idleness 20 | 21 | function Find_Idle (From : in out Pool; Grow : Boolean := True) return Single.Ptr; 22 | -- Returns next idle thread, or create one if Grow and none idle (can go beyond initial size) 23 | -- Returns next non-idle if none idle and not grow 24 | -- NOTE: THIS IS O(N) in the current implementation 25 | 26 | function New_One (From : in out Pool) return Single.Ptr; 27 | -- Grows the pool and returns the new one 28 | 29 | private 30 | 31 | use type Single.Ptr; 32 | 33 | package Thread_Vectors is new Ada.Containers.Vectors (Positive, Single.Ptr); 34 | 35 | protected type Safe_Pool (Parent : access Pool) is 36 | 37 | procedure Advance; 38 | 39 | procedure Append (Thread : Single.Ptr); 40 | -- Append a new single y return the current number in the pool 41 | -- There's potential for race conditions here in which we could end with some extra threads 42 | -- But it may serve as a simpler implementation 43 | 44 | procedure Curr (Thread : out Single.Ptr); 45 | 46 | procedure Find_Idle (Thread : out Single.Ptr); 47 | 48 | function Exists return Boolean; 49 | -- Say if the Current thread exists 50 | 51 | function Thread_Count return Natural; 52 | 53 | private 54 | Threads : Thread_Vectors.Vector; 55 | Current : Positive := 1; 56 | Size : Positive := Parent.Initial_Size; 57 | -- Max of the actual size or initial size 58 | -- There might be less than Size created elements in Threads 59 | end Safe_Pool; 60 | 61 | type Pool (Initial_Size : Positive := 8; Name : String_Access := new String'("anonymous")) 62 | is new Ada.Finalization.Limited_Controlled with record 63 | Safe : Safe_Pool (Pool'Access); 64 | end record; 65 | 66 | function Grow (This : in out Pool) return Single.Ptr; 67 | -- Adds a thread and returns it, going beyond initial capacity if necessary 68 | 69 | function Ensure_Exists (This : in out Pool) return Single.Ptr; 70 | -- Returns null if already exists, or else the newly created thread 71 | 72 | overriding procedure Finalize (This : in out Pool); 73 | 74 | end Rx.Dispatchers.Pools; 75 | -------------------------------------------------------------------------------- /src/priv/rx-dispatchers-single-lazy.ads: -------------------------------------------------------------------------------- 1 | with Rx.Tools.Lazies; 2 | 3 | package Rx.Dispatchers.Single.Lazy is new Rx.Tools.Lazies (Single.Dispatcher, Single.Ptr); 4 | -------------------------------------------------------------------------------- /src/priv/rx-dispatchers.ads: -------------------------------------------------------------------------------- 1 | with Ada.Calendar; 2 | 3 | with Rx.Errors; 4 | with Rx.Impl.Shared_Observer; 5 | with Rx.Impl.Preservers; 6 | with Rx.Impl.Typed; 7 | 8 | package Rx.Dispatchers is 9 | 10 | pragma Elaborate_Body; 11 | 12 | type Dispatcher is limited interface; 13 | 14 | type Runnable is interface; 15 | 16 | -- Not made explicit, but implementors of this class are (and must be) 17 | -- synchronized 18 | 19 | procedure Run (This : Runnable) is abstract; 20 | 21 | -- Schedule a code to be run at a certain time, in a certain scheduler (thread) 22 | procedure Schedule (Where : in out Dispatcher; 23 | What : Runnable'Class; 24 | Time : Ada.Calendar.Time := Ada.Calendar.Clock) is abstract; 25 | 26 | generic 27 | with package Typed is new Rx.Impl.Typed (<>); 28 | package Events is 29 | 30 | package Shared is new Rx.Impl.Shared_Observer (Typed); 31 | 32 | procedure On_Next (Sched : in out Dispatcher'Class; Observer : Shared.Observer; V : Typed.Type_Traits.T); 33 | procedure On_Complete (Sched : in out Dispatcher'Class; Observer : Shared.Observer); 34 | procedure On_Error (Sched : in out Dispatcher'Class; Observer : Shared.Observer; E : Rx.Errors.Occurrence); 35 | 36 | end Events; 37 | 38 | generic 39 | with package Operate is new Rx.Impl.Preservers (<>); 40 | package Subscribe is 41 | 42 | procedure On_Subscribe (Sched : in out Dispatcher'Class; 43 | Parent : Operate.Observable'Class; 44 | Child : Operate.Into.Observer'Class); 45 | 46 | end Subscribe; 47 | 48 | procedure Shutdown; 49 | -- Signal schedulers to exit. 50 | -- Necessary when there are infinite sequences going on (e.g. Interval) 51 | 52 | function Terminating return Boolean; 53 | -- Will be true after shutdown has been invoked 54 | 55 | end Rx.Dispatchers; 56 | -------------------------------------------------------------------------------- /src/priv/rx-impl-casts.ads: -------------------------------------------------------------------------------- 1 | with Ada.Strings; use Ada.Strings; 2 | with Ada.Strings.Fixed; use Ada.Strings.Fixed; 3 | 4 | package Rx.Impl.Casts is 5 | 6 | -- Casts between the standard Ada types for use in the Cast operator 7 | 8 | function To_Integer (V : Rx_Float) return Rx_Integer is (Rx_Integer (V)); 9 | function To_Integer (V : Rx_String) return Rx_Integer is (Rx_Integer'Value (V)); 10 | 11 | function To_Float (V : Rx_Integer) return Rx_Float is (Rx_Float (V)); 12 | function To_Float (V : Rx_String) return Rx_Float is (Rx_Float'Value (V)); 13 | 14 | function To_String (V : Rx_Integer) return String is (Trim (Rx_Integer'Image (V), Both)); 15 | function To_String (V : Rx_Float) return String is (Trim (Rx_Float'Image (V), Both)); 16 | function To_String (V : Rx_String) return String is (V); 17 | -- A default conversion with 4 decimal digits 18 | 19 | end Rx.Impl.Casts; 20 | -------------------------------------------------------------------------------- /src/priv/rx-impl-definite_observables.ads: -------------------------------------------------------------------------------- 1 | with Rx.Contracts; 2 | with Rx.Tools.Holders; 3 | 4 | generic 5 | with package Contracts is new Rx.Contracts (<>); 6 | package Rx.Impl.Definite_Observables is 7 | 8 | pragma Preelaborate; 9 | 10 | type Observable is new Contracts.Observable with private; 11 | 12 | overriding 13 | procedure Subscribe (Producer : in out Observable; 14 | Consumer : in out Contracts.Observer'Class); 15 | 16 | function From (Indef : Contracts.Observable'Class) return Observable; 17 | function "+" (Indef : Contracts.Observable'Class) return Observable renames From; 18 | 19 | procedure From (This : in out Observable; Indef : Contracts.Observable'Class); 20 | 21 | function To_Indef (This : Observable) return Contracts.Observable'Class; 22 | 23 | function Is_Valid (This : Observable) return Boolean; 24 | 25 | private 26 | 27 | package Obs_Holders is new Rx.Tools.Holders (Contracts.Observable'Class, "definite_observable'class"); 28 | 29 | type Observable is new Obs_Holders.Definite and Contracts.Observable with null record; 30 | 31 | function To_Indef (This : Observable) return Contracts.Observable'Class is (This.Get); 32 | 33 | overriding 34 | function Is_Valid (This : Observable) return Boolean is 35 | (Obs_Holders.Definite (This).Is_Valid); 36 | 37 | end Rx.Impl.Definite_Observables; 38 | -------------------------------------------------------------------------------- /src/priv/rx-impl-definite_observers.ads: -------------------------------------------------------------------------------- 1 | with Rx.Contracts; 2 | with Rx.Errors; 3 | 4 | private with Rx.Tools.Holders; 5 | 6 | generic 7 | with package Contracts is new Rx.Contracts (<>); 8 | package Rx.Impl.Definite_Observers with Preelaborate is 9 | 10 | type Observer is new Contracts.Observer with private; 11 | 12 | -- A wrapper over the class to use it as definite 13 | 14 | function Create (From : Contracts.Observer'Class) return Observer 15 | with Post => Create'Result.Is_Valid; 16 | 17 | overriding procedure On_Next (This : in out Observer; V : Contracts.T) 18 | with Pre => This.Is_Valid or else raise Constraint_Error; 19 | 20 | overriding procedure On_Complete (This : in out Observer) 21 | with Pre => This.Is_Valid or else raise Constraint_Error; 22 | 23 | overriding procedure On_Error (This : in out Observer; Error : Errors.Occurrence) 24 | with Pre => This.Is_Valid or else raise Constraint_Error; 25 | 26 | function Is_Valid (This : Observer) return Boolean; 27 | 28 | procedure Clear (This : in out Observer) 29 | with Post => not This.Is_Valid; 30 | 31 | private 32 | 33 | package Holders is new Rx.Tools.Holders (Contracts.Observer'Class); 34 | 35 | type Observer is new Contracts.Observer with record 36 | Actual : Holders.Definite; 37 | end record; 38 | 39 | end Rx.Impl.Definite_Observers; 40 | -------------------------------------------------------------------------------- /src/priv/rx-impl-events.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | 3 | with Rx.Errors; 4 | with Rx.Impl.Typed; 5 | 6 | generic 7 | with package Typed is new Rx.Impl.Typed (<>); 8 | package Rx.Impl.Events is 9 | 10 | type Kinds is (On_Next, On_Complete , On_Error); 11 | 12 | type Event (Kind : Kinds) is private; 13 | 14 | function On_Next (V : Typed.T) return Event; 15 | 16 | function On_Complete return Event; 17 | 18 | function On_Error (E : Errors.Occurrence) return Event; 19 | 20 | function On_Error (E : Ada.Exceptions.Exception_Occurrence) return Event; 21 | 22 | function Value (E : Event) return Typed.T 23 | with Pre => E.Kind = On_Next; 24 | 25 | function Error (E : Event) return Errors.Occurrence 26 | with Pre => E.Kind = On_Error; 27 | 28 | private 29 | 30 | type Event (Kind : Kinds) is record 31 | case Kind is 32 | when On_Next => V : Typed.D; 33 | when On_Error => E : Errors.Occurrence; 34 | when On_Complete => null; 35 | end case; 36 | end record; 37 | 38 | use Typed.Conversions; 39 | 40 | function On_Next (V : Typed.T) return Event is (On_Next, +V); 41 | 42 | function On_Complete return Event is (Kind => On_Complete ); 43 | 44 | function On_Error (E : Errors.Occurrence) return Event is (On_Error, E); 45 | 46 | function On_Error (E : Ada.Exceptions.Exception_Occurrence) return Event is (On_Error, Errors.Create (E)); 47 | 48 | function Value (E : Event) return Typed.T is (+E.V); 49 | 50 | function Error (E : Event) return Errors.Occurrence is (E.E); 51 | 52 | end Rx.Impl.Events; 53 | -------------------------------------------------------------------------------- /src/priv/rx-impl-holders.ads: -------------------------------------------------------------------------------- 1 | with Rx.Contracts; 2 | with Rx.Tools.Holders; 3 | 4 | generic 5 | with package Contracts is new Rx.Contracts (<>); 6 | package Rx.Impl.Holders with Preelaborate is 7 | 8 | package Observables is new Rx.Tools.Holders (Contracts.Observable'Class, 9 | "contracts.observable'class"); 10 | type Observable is new Observables.Definite with null record; 11 | 12 | package Observers is new Rx.Tools.Holders (Contracts.Observer'Class, 13 | "contracts.observer'class"); 14 | type Observer is new Observers.Definite with null record; 15 | 16 | package Subscribers is new Rx.Tools.Holders (Contracts.Subscriber'Class, 17 | "contracts.subscriber'class"); 18 | type Subscriber is new Subscribers.Definite with null record; 19 | 20 | end Rx.Impl.Holders; 21 | -------------------------------------------------------------------------------- /src/priv/rx-impl-links.ads: -------------------------------------------------------------------------------- 1 | with Rx.Tools.Holders; 2 | with Rx.Impl.Typed; 3 | 4 | generic 5 | with package Typed is new Rx.Impl.Typed (<>); 6 | package Rx.Impl.Links is 7 | 8 | pragma Preelaborate; 9 | 10 | -- Types needed for: 11 | -- 1) Building the passive chains pre-subscription 12 | -- 2) The active copy of a chain post-subscription 13 | 14 | type Downstream is abstract tagged private; 15 | -- An entity able to have a stored parent observable 16 | 17 | procedure Set_Parent (This : in out Downstream; Parent : Typed.Contracts.Observable'Class); 18 | 19 | function Has_Parent (This : Downstream) return Boolean; 20 | 21 | function Get_Parent (This : Downstream) return Typed.Contracts.Observable'Class; 22 | 23 | function Ref_Parent (This : in out Downstream) return access Typed.Contracts.Observable'Class; 24 | -- Access the stored parent itself 25 | -- Not necessary generally; except for some cross-type advanced operations related to flat_map 26 | -- See Rx.Operators.Set_Parent 27 | 28 | private 29 | 30 | package Holders is new Rx.Tools.Holders (Typed.Contracts.Observable'Class, "observable'class"); 31 | type Holder is new Holders.Definite with null record; 32 | 33 | type Downstream is abstract tagged record 34 | Parent : Holder; 35 | end record; 36 | 37 | function Has_Parent (This : Downstream) return Boolean is 38 | (not This.Parent.Is_Empty); 39 | 40 | function Get_Parent (This : Downstream) return Typed.Contracts.Observable'Class is 41 | (This.Parent.Get); 42 | 43 | function Ref_Parent (This : in out Downstream) return access Typed.Contracts.Observable'Class is 44 | (This.Parent.Ref.Actual); 45 | 46 | end Rx.Impl.Links; 47 | -------------------------------------------------------------------------------- /src/priv/rx-impl-preservers.ads: -------------------------------------------------------------------------------- 1 | with Rx.Tools.Holders; 2 | with Rx.Impl.Transformers; 3 | with Rx.Impl.Typed; 4 | 5 | generic 6 | with package Typed is new Rx.Impl.Typed (<>); 7 | package Rx.Impl.Preservers with Preelaborate is 8 | 9 | -- Specialized Transform, but with type preservation 10 | -- A separate package is convenient to allow independent package files for this kind of operators 11 | 12 | -- Shortcuts & bug workarounds 13 | subtype T is Typed.Type_Traits.T; 14 | subtype Observable is Typed.Observable'Class; 15 | subtype Observer is Typed.Observer'Class; 16 | 17 | package Transform is new Rx.Impl.Transformers (Typed, Typed); 18 | -- Specialization with type preservation here 19 | 20 | subtype Operator is Transform.Operator; 21 | -- Specialization of the Transformer type 22 | 23 | package From renames Transform.From; 24 | package Into renames Transform.Into; 25 | 26 | function Identity (V : From.T) return Into.T is (V); 27 | 28 | function Concatenate (Producer : Typed.Contracts.Observable'Class; 29 | Consumer : Transform.Operator'Class) 30 | return Typed.Observable renames Transform.Concatenate; 31 | -- Shortcut for simpler use elsewhere (particularly in Rx.Observables) 32 | 33 | package Linkers renames Transform.Linkers; 34 | -- Useable package 35 | 36 | package Holders is new Rx.Tools.Holders (Operator'Class, "operator'class"); 37 | 38 | end Rx.Impl.Preservers; 39 | -------------------------------------------------------------------------------- /src/priv/rx-impl-shared_observer.ads: -------------------------------------------------------------------------------- 1 | with Rx.Errors; 2 | with Rx.Impl.Typed; 3 | 4 | private with Rx.Impl.Definite_Observers; 5 | private with Rx.Tools.Shared_Data; 6 | 7 | generic 8 | with package Typed is new Rx.Impl.Typed (<>); 9 | package Rx.Impl.Shared_Observer with Preelaborate is 10 | 11 | type Observer is new Typed.Contracts.Observer with private; 12 | -- In essence this is a carcass for a pointed to observer. 13 | -- This way, both threads using it access the same actual Observer. 14 | -- Deallocation is properly done in On_Complete /On_Error 15 | 16 | -- Thread-safe 17 | 18 | function Create (Held : Typed.Observer; 19 | Checked : Boolean := True) return Observer; 20 | -- If checked, then only On_Complete/On_Error is allowed 21 | -- No check is performed otherwise (useful in e.g. Merge/Funnel) 22 | 23 | overriding procedure On_Next (This : in out Observer; V : Typed.Type_Traits.T); 24 | overriding procedure On_Complete (This : in out Observer); 25 | overriding procedure On_Error (This : in out Observer; Error : Errors.Occurrence); 26 | 27 | function Is_Completed (This : Observer) return Boolean; 28 | 29 | procedure Mark_Completed (This : in out Observer); 30 | 31 | private 32 | 33 | -- The conceptually simple initial design, alas, cannot be: when subscrip- 34 | -- tions end downstream, and a remote operator is in mid-chain (e.g., 35 | -- Observe_On), there's no simple way to inform upstream, that has copies 36 | -- of the same Shared_Observer. Thus, we have to keep track of how many 37 | -- copies of an observer still remain. 38 | -- Furthermore, since an observed gets stored in different threads (e.g. 39 | -- when Observe_On/Interval is involved), we need full thread-safety. 40 | 41 | package Definite_Observers is new Impl.Definite_Observers (Typed.Contracts); 42 | 43 | type Inner_Observer is limited record 44 | Actual : Definite_Observers.Observer; 45 | Checked : Boolean := True; 46 | Ended : Boolean := False; 47 | end record; 48 | 49 | type Inner_Observer_Access is access Inner_Observer; 50 | 51 | package Safe_Observers is new Tools.Shared_Data (Inner_Observer, 52 | Inner_Observer_Access, 53 | "shared_observer"); 54 | 55 | type Observer is new Safe_Observers.Proxy and Typed.Contracts.Observer 56 | with null record; 57 | 58 | function Ref (This : in out Observer) return Safe_Observers.Ref; 59 | 60 | end Rx.Impl.Shared_Observer; 61 | -------------------------------------------------------------------------------- /src/priv/rx-impl-std.ads: -------------------------------------------------------------------------------- 1 | with Rx.Definites; 2 | with Rx.Indefinites; 3 | with Rx.Numeric_Observables; 4 | with Rx.Numeric_Operators; 5 | with Rx.Operators; 6 | with Rx.Valueless; 7 | 8 | package Rx.Impl.Std is 9 | 10 | package Floats is new Rx.Definites (Rx_Float); 11 | package Integers is new Rx.Definites (Rx_Integer); 12 | package Strings is new Rx.Indefinites (Rx_String); 13 | package Nothings is new Rx.Definites (Valueless.Nothing); 14 | 15 | package Int_To_Float is new Rx.Operators (Integers.Observables, Floats.Observables); 16 | package String_To_Float is new Rx.Operators (Strings.Observables, Floats.Observables); 17 | 18 | package Float_To_Integer is new Rx.Operators (Floats.Observables, Integers.Observables); 19 | package String_To_Integer is new Rx.Operators (Strings.Observables, Integers.Observables); 20 | 21 | package Float_To_String is new Rx.Operators (Floats.Observables, Strings.Observables); 22 | package Integer_To_String is new Rx.Operators (Integers.Observables, Strings.Observables); 23 | 24 | function To_Integer (I : Rx_Integer) return Rx_Integer is (I); 25 | function To_Float (I : Rx_Integer) return Rx_Float is (Rx_Float (I)); 26 | function Succ (F : Rx_Float) return Rx_Float is (F + 1.0); 27 | 28 | package Numeric is 29 | 30 | -- Encapsulate numeric observables 31 | 32 | package Integers is new Numeric_Observables (Integers.Observables, 33 | To_Integer, 34 | Rx_Integer'Succ); 35 | 36 | package Floats is new Numeric_Observables (Floats.Observables, 37 | To_Float, 38 | Succ); 39 | 40 | package Str_To_Int is new Rx.Numeric_Operators (String_To_Integer, 41 | To_Integer, 42 | Rx_Integer'Succ); 43 | 44 | end Numeric; 45 | 46 | end Rx.Impl.Std; 47 | -------------------------------------------------------------------------------- /src/priv/rx-impl-typed.ads: -------------------------------------------------------------------------------- 1 | with Rx.Actions; 2 | with Rx.Actions.Typed; 3 | with Rx.Contracts; 4 | with Rx.Conversions; 5 | with Rx.Defaults; 6 | with Rx.Factories; 7 | with Rx.Impl.Definite_Observables; 8 | with Rx.Impl.Definite_Observers; 9 | with Rx.Impl.Holders; 10 | with Rx.Traits.Types; 11 | 12 | generic 13 | with package Type_Traits is new Rx.Traits.Types (<>); 14 | package Rx.Impl.Typed with Preelaborate is 15 | 16 | package Contracts is new Rx.Contracts (Type_Traits.T); 17 | -- The beginning of it all 18 | 19 | package Actions is new Rx.Actions.Typed (Type_Traits.T); 20 | 21 | -- Shortcuts 22 | subtype T is Type_Traits.T; 23 | subtype D is Type_Traits.D; 24 | subtype Observable is Contracts.Observable'Class; 25 | subtype Observer is Contracts.Observer'Class; 26 | subtype Sink is Contracts.Sink'Class; 27 | subtype Subscriber is Contracts.Subscriber'Class; 28 | 29 | -- Typed packages for use with an Rx type 30 | 31 | package Defaults is new Rx.Defaults (Contracts); 32 | package Definite_Observables is new Impl.Definite_Observables (Contracts); 33 | package Definite_Observers is new Impl.Definite_Observers (Contracts); 34 | package Conversions is new Rx.Conversions (Type_Traits); 35 | package Factories is new Rx.Factories (Contracts); 36 | package Holders is new Impl.Holders (Contracts); 37 | 38 | end Rx.Impl.Typed; 39 | -------------------------------------------------------------------------------- /src/priv/rx-impl.ads: -------------------------------------------------------------------------------- 1 | package Rx.Impl with Pure is 2 | 3 | -- Root for implementation helper packages 4 | 5 | end Rx.Impl; 6 | -------------------------------------------------------------------------------- /src/priv/rx-op-buffer.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Transform is new Rx.Impl.Transformers (<>); 5 | Empty : Transform.Into.D; 6 | with procedure Append (Container : in out Transform.Into.D; V : Transform.From.T) is <>; 7 | package Rx.Op.Buffer with Preelaborate is 8 | 9 | -- The use of definites in the generic formal presumes some form of definite container that will 10 | -- be the same type as the indefinite 11 | 12 | 13 | function Create (Every : Positive; Skip : Natural := 0) return Transform.Operator'Class; 14 | -- Builds lists of size Every, discarding Skip between each one 15 | 16 | end Rx.Op.Buffer; 17 | -------------------------------------------------------------------------------- /src/priv/rx-op-count.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Transform is new Rx.Impl.Transformers (<>); -- Items to be counted and into what 5 | with function Succ (V : Transform.Into.T) return Transform.Into.T; 6 | Default_Initial_Count : Transform.Into.T; 7 | package Rx.Op.Count is 8 | 9 | function Count (First : Transform.Into.T := Default_Initial_Count) 10 | return Transform.Operator'Class; 11 | 12 | end Rx.Op.Count; 13 | -------------------------------------------------------------------------------- /src/priv/rx-op-debounce.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Debounce is 6 | 7 | function Create (Window : Duration) return Operate.Operator'Class; 8 | 9 | end Rx.Op.Debounce; 10 | -------------------------------------------------------------------------------- /src/priv/rx-op-distinct.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Distinct is 6 | 7 | function Default_Not_Same (L, R : Operate.T) return Boolean; 8 | 9 | function Create (Are_Distinct : Operate.Typed.Actions.Comparator := Default_Not_Same'Access) 10 | return Operate.Operator'Class; 11 | -- When null, default "=" is used to compare elements 12 | 13 | private 14 | 15 | use type Operate.T; 16 | 17 | function Default_Not_Same (L, R : Operate.T) return Boolean is (L /= R); 18 | 19 | end Rx.Op.Distinct; 20 | -------------------------------------------------------------------------------- /src/priv/rx-op-do_on.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Preserver is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Do_On is 6 | 7 | function Create (On_Next : Preserver.Typed.Actions.TProc1'Class) 8 | return Preserver.Operator'Class; 9 | 10 | end Rx.Op.Do_On; 11 | -------------------------------------------------------------------------------- /src/priv/rx-op-element_at.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Element_At with Preelaborate is 6 | 7 | function Create (Pos : Rx_Integer; 8 | First : Rx_Integer := 1) -- 1-based by default 9 | return Operate.Operator'Class 10 | with Pre => Pos >= First; 11 | -- If Pos is not reached, Constraint_Error 12 | 13 | function Or_Default (Default : Operate.T; 14 | Pos : Rx_Integer; 15 | First : Rx_Integer := 1) 16 | return Operate.Operator'Class 17 | with Pre => Pos >= First; 18 | 19 | end Rx.Op.Element_At; 20 | -------------------------------------------------------------------------------- /src/priv/rx-op-filter.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Filter is 6 | 7 | function Create (Filter : not null Operate.Typed.Actions.Filter1) 8 | return Operate.Operator'Class; 9 | 10 | function Create (Filter : Operate.Typed.Actions.TFilter1'Class) 11 | return Operate.Operator'Class; 12 | 13 | end Rx.Op.Filter; 14 | -------------------------------------------------------------------------------- /src/priv/rx-op-funnel.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Preserver is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Funnel is 6 | 7 | -- Special internal operator used to implement multiobservers. 8 | -- Once subscribed, all copies have a shared downstream observer. 9 | 10 | -- The returned operator is thread-safe (via Op.Serialize) 11 | 12 | function Create return Preserver.Operator'Class; 13 | -- Shared downstream upon On_Subscribe 14 | 15 | end Rx.Op.Funnel; 16 | -------------------------------------------------------------------------------- /src/priv/rx-op-hold.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Preserver is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Hold is 6 | 7 | function Create (Fixed : Duration; 8 | Random : Duration := 0.0) 9 | return Preserver.Operator'Class; 10 | -- Hold items for a certain time before releasing them 11 | -- A fixed amount is always applied, and a random one on top 12 | -- This is a blocking delay! Use appropriate operators to schedule 13 | 14 | end Rx.Op.Hold; 15 | -------------------------------------------------------------------------------- /src/priv/rx-op-last.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Last with Preelaborate is 6 | 7 | function Create (Check : Operate.Typed.Actions.TFilter1'Class := Operate.Typed.Actions.Always_Pass) 8 | return Operate.Operator'Class; 9 | -- If no item is seen Constraint_Error will be raised when On_Complete 10 | 11 | function Or_Default (Default : Operate.T; 12 | Check : Operate.Typed.Actions.TFilter1'Class := Operate.Typed.Actions.Always_Pass) 13 | return Operate.Operator'Class; 14 | 15 | end Rx.Op.Last; 16 | -------------------------------------------------------------------------------- /src/priv/rx-op-length.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Transform is new Rx.Impl.Transformers (<>); 5 | with function Length (V : Transform.From.T) return Transform.Into.T is <>; 6 | package Rx.Op.Length with Preelaborate is 7 | 8 | function Create return Transform.Operator'Class; 9 | -- Emits the length of each input item 10 | 11 | end Rx.Op.Length; 12 | -------------------------------------------------------------------------------- /src/priv/rx-op-limit.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Limit is 6 | 7 | function Create (Limit : Rx_Natural) return Operate.Operator'Class; 8 | -- If limit is 0, On_Complete will be called upon first On_Next (but not instantly at subscription time). 9 | -- This is according to RxJava implementation, there is no explicit behavior in Rx specs. 10 | 11 | end Rx.Op.Limit; 12 | -------------------------------------------------------------------------------- /src/priv/rx-op-map.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Transformers (<>); 5 | package Rx.Op.Map with Preelaborate is 6 | 7 | function Create (F : Typed.Actions.Func1) return Typed.Operator'Class; 8 | 9 | function "&" (Producer : Typed.From.Observable; 10 | Consumer : Typed.Actions.Func1) 11 | return Typed.Into.Observable; 12 | -- Since Ada has this unlike Java, we can have a special case concatenator for the Map operation, 13 | -- that saves explicit "Map": 14 | -- Some_Operator & Some_Action'Access & Some_Other_Operator 15 | -- instead of: 16 | -- Some_Operator & Map (Some_Action'Access) & Some_Other_Operator 17 | 18 | end Rx.Op.Map; 19 | -------------------------------------------------------------------------------- /src/priv/rx-op-merge.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | private with Rx.Op.Observe_On; 4 | 5 | generic 6 | with package Preserver is new Rx.Impl.Preservers (<>); 7 | package Rx.Op.Merge is 8 | 9 | function Create (Merge_With : Preserver.Observable'Class; 10 | Policy : Merge_Policies := Rx.Merge) 11 | return Preserver.Operator'Class; 12 | -- Observe_On is used for the Merge_With observable only 13 | 14 | function Create (One, Two : Preserver.Observable'Class; 15 | Policy : Merge_Policies := Rx.Merge) 16 | return Preserver.Observable'Class; 17 | 18 | private 19 | 20 | use Preserver.Linkers; 21 | 22 | package RxObserve is new Rx.Op.Observe_On (Preserver); 23 | 24 | function Create (One, Two : Preserver.Observable'Class; 25 | Policy : Merge_Policies := Rx.Merge) 26 | return Preserver.Observable'Class is 27 | (One 28 | & Create (Two, Policy)); 29 | 30 | end Rx.Op.Merge; 31 | -------------------------------------------------------------------------------- /src/priv/rx-op-no_op.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Preserver is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.No_Op is 6 | 7 | function Create return Preserver.Operator'Class; 8 | 9 | end Rx.Op.No_Op; 10 | -------------------------------------------------------------------------------- /src/priv/rx-op-observe_on.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | with Rx.Schedulers; 3 | 4 | generic 5 | with package Operate is new Rx.Impl.Preservers (<>); 6 | package Rx.Op.Observe_On is 7 | 8 | function Create (Scheduler : Schedulers.Scheduler) return Operate.Operator'Class; 9 | 10 | end Rx.Op.Observe_On; 11 | -------------------------------------------------------------------------------- /src/priv/rx-op-print.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Print is 6 | 7 | function Create (Func : Operate.Typed.Actions.Func1Str := null; With_Timestamp : Boolean := True) 8 | return Operate.Operator'Class; 9 | -- If null, the current thread id will be printed 10 | 11 | end Rx.Op.Print; 12 | -------------------------------------------------------------------------------- /src/priv/rx-op-repeat.ads: -------------------------------------------------------------------------------- 1 | with Rx.Actions; 2 | with Rx.Impl.Preservers; 3 | 4 | generic 5 | with package Operate is new Rx.Impl.Preservers (<>); 6 | package Rx.Op.Repeat is 7 | 8 | function Repeat_Forever return Operate.Operator'Class; 9 | 10 | function Repeat (Times : Rx_Integer) return Operate.Operator'Class; 11 | 12 | function While_Do (Check : Actions.TFilter0'Class) return Operate.Operator'Class; 13 | -- The check is performed before each repetition 14 | 15 | function Repeat_Until (Check : Actions.TFilter0'Class) return Operate.Operator'Class; 16 | -- The check is performed after each repetition 17 | 18 | end Rx.Op.Repeat; 19 | -------------------------------------------------------------------------------- /src/priv/rx-op-sample.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | with Rx.Impl.Typed; 3 | 4 | generic 5 | with package Operate is new Rx.Impl.Preservers (<>); 6 | with package Samplers is new Rx.Impl.Typed (<>); 7 | package Rx.Op.Sample is 8 | 9 | type Policies is (Keep_First, Keep_Last); 10 | 11 | function Create (Policy : Policies; 12 | Sampler : Samplers.Observable'Class) return Operate.Operator'Class; 13 | 14 | end Rx.Op.Sample; 15 | -------------------------------------------------------------------------------- /src/priv/rx-op-scan.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Transformers (<>); 5 | package Rx.Op.Scan is 6 | 7 | function Create (Func : Typed.Actions.Func2; 8 | Seed : Typed.Into.T; 9 | Emit : Boolean := False) -- If the seed has to be emitted 10 | return Typed.Operator'Class; 11 | 12 | end Rx.Op.Scan; 13 | -------------------------------------------------------------------------------- /src/priv/rx-op-serialize.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Serialize is 6 | 7 | function Create return Operate.Operator'Class; 8 | 9 | -- Serializes calls to On_* 10 | -- Does not serialize calls to Subscribe/Unsubscribe 11 | -- which, unless something very strange is happening, 12 | -- should happen from a single thread 13 | 14 | end Rx.Op.Serialize; 15 | -------------------------------------------------------------------------------- /src/priv/rx-op-split.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Transformers; 2 | 3 | generic 4 | with package Transform is new Rx.Impl.Transformers (<>); 5 | with procedure Iterate (V : Transform.From.T; 6 | For_Each : access procedure (V : Transform.Into.T)) is <>; 7 | package Rx.Op.Split is 8 | 9 | function Create return Transform.Operator'Class; 10 | 11 | end Rx.Op.Split; 12 | -------------------------------------------------------------------------------- /src/priv/rx-op-stopwatch.ads: -------------------------------------------------------------------------------- 1 | with Rx.Actions; 2 | with Rx.Impl.Preservers; 3 | 4 | generic 5 | with package Preserver is new Rx.Impl.Preservers (<>); 6 | package Rx.Op.Stopwatch is 7 | 8 | function Create (Callback : not null Actions.Inspector) 9 | return Preserver.Operator'Class; 10 | -- Calls its inspector on every event, with the cumulative and differential 11 | -- elapsed time. 12 | 13 | end Rx.Op.Stopwatch; 14 | -------------------------------------------------------------------------------- /src/priv/rx-op-subscribe_on.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | with Rx.Schedulers; 3 | 4 | generic 5 | with package Operate is new Rx.Impl.Preservers (<>); 6 | package Rx.Op.Subscribe_On is 7 | 8 | function Create (Scheduler : Schedulers.Scheduler) return Operate.Operator'Class; 9 | 10 | end Rx.Op.Subscribe_On; 11 | -------------------------------------------------------------------------------- /src/priv/rx-op-take.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Preservers; 2 | 3 | generic 4 | with package Operate is new Rx.Impl.Preservers (<>); 5 | package Rx.Op.Take is 6 | 7 | package Actions renames Operate.Typed.Actions; 8 | 9 | function Create (Pass : Actions.TFilter1'Class; Emit_Last : Boolean) return Operate.Operator'Class; 10 | -- Emit_Last is used to differentiate While and Until, since the former won't emit the one failing Pass, 11 | -- whereas Until will 12 | 13 | function Take_Count (Count : Rx_Natural) return Operate.Operator'Class; 14 | 15 | function Take_While (Check : Actions.TFilter1'Class) return Operate.Operator'Class; 16 | 17 | function Take_Until (Check : Actions.TFilter1'Class) return Operate.Operator'Class; 18 | 19 | function Create (During : Duration) return Operate.Operator'Class; 20 | 21 | end Rx.Op.Take; 22 | -------------------------------------------------------------------------------- /src/priv/rx-op.ads: -------------------------------------------------------------------------------- 1 | package Rx.Op with Pure is 2 | 3 | private 4 | 5 | function Always return Boolean is (True); 6 | 7 | end Rx.Op; 8 | -------------------------------------------------------------------------------- /src/priv/rx-src-create.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | package Rx.Src.Create with Preelaborate is 6 | 7 | package Contracts renames Typed.Contracts; 8 | 9 | -- Three ways of easily creating a new observable for custom emision 10 | 11 | function Parameterless (On_Subscribe : not null access procedure (Observer : in out Typed.Observer)) 12 | return Typed.Observable; 13 | -- Creates an Observable that requires no parameters, from a procedure that calls the Observer 14 | -- Does not autocomplete 15 | 16 | function Enumerator (Initial : Typed.T; 17 | Succ : not null Typed.Actions.Func1; 18 | Count : Rx_Integer := Rx_Integer'Last) return Typed.Observable; 19 | -- Observable from a function that, given a value, produces the next one 20 | 21 | generic 22 | type State is private; 23 | with procedure On_Subscribe (Initial : State; 24 | Observer : in out Typed.Observer) is <>; 25 | Autocompletes : Boolean := True; 26 | -- Generic observable that can produce all its items from an initial value 27 | -- and hence doesn't need to retain a state going on. 28 | -- The call to On_Complete is automatically performed after On_Subscribe if Completes = True 29 | package With_State is 30 | 31 | function Create (Initial : State) return Typed.Observable; 32 | -- Creates an observable that can receive different initial states 33 | -- On_Complete is optionally automatically called 34 | 35 | end With_State; 36 | 37 | end Rx.Src.Create; 38 | -------------------------------------------------------------------------------- /src/priv/rx-src-defer.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | package Rx.Src.Defer is 6 | 7 | package Factories renames Typed.Factories; 8 | 9 | function Create (F : Factories.Observable_Factory'Class) return Typed.Observable; 10 | -- The factory code won't be invoked until actual subscription time 11 | 12 | function Create (F : Factories.Observable_Factory_Func) return Typed.Observable; 13 | 14 | end Rx.Src.Defer; 15 | -------------------------------------------------------------------------------- /src/priv/rx-src-empty.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | 3 | with Rx.Errors; 4 | with Rx.Impl.Typed; 5 | 6 | generic 7 | with package Typed is new Rx.Impl.Typed (<>); 8 | package Rx.Src.Empty is 9 | 10 | function Empty return Typed.Observable; 11 | 12 | function Never return Typed.Observable; 13 | 14 | function Error (E : Rx.Errors.Occurrence) return Typed.Observable; 15 | function Error (E : Ada.Exceptions.Exception_Occurrence) return Typed.Observable; 16 | 17 | end Rx.Src.Empty; 18 | -------------------------------------------------------------------------------- /src/priv/rx-src-from.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Arrays; 2 | with Rx.Traits.Iterable; 3 | 4 | package Rx.Src.From is 5 | 6 | -- pragma Preelaborate; 7 | 8 | generic 9 | with package Arrays is new Rx.Traits.Arrays (<>); 10 | package From_Array is 11 | function From (A : Arrays.Typed_Array) return Arrays.Typed.Observable; 12 | end From_Array; 13 | 14 | generic 15 | with package Iterable is new Rx.Traits.Iterable (<>); 16 | package From_Iterable is 17 | function From (C : Iterable.Container) return Iterable.Typed.Observable; 18 | end From_Iterable; 19 | 20 | end Rx.Src.From; 21 | -------------------------------------------------------------------------------- /src/priv/rx-src-interval.ads: -------------------------------------------------------------------------------- 1 | with Rx.Schedulers; 2 | with Rx.Impl.Typed; 3 | 4 | generic 5 | with package Typed is new Rx.Impl.Typed (<>); -- Items emitted 6 | with function Succ (V : Typed.T) return Typed.T; -- Next in sequence 7 | package Rx.Src.Interval is 8 | 9 | pragma Elaborate_Body; 10 | 11 | function Create (First : Typed.T; 12 | Period : Duration := 1.0; 13 | First_Pause : Duration := 0.0; 14 | Scheduler : Schedulers.Scheduler := Schedulers.Computation) 15 | return Typed.Observable; 16 | -- Delay Until is used, so slow processing may mean trouble... 17 | 18 | end Rx.Src.Interval; 19 | -------------------------------------------------------------------------------- /src/priv/rx-src-just.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | package Rx.Src.Just is 6 | 7 | function Create (V : Typed.T) return Typed.Observable'Class; 8 | 9 | end Rx.Src.Just; 10 | -------------------------------------------------------------------------------- /src/priv/rx-src-ranges.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | with function Succ (V : Typed.T) return Typed.T is <>; 6 | with function "<" (L, R : Typed.T) return Boolean is <>; 7 | package Rx.Src.Ranges is 8 | 9 | function From_Count (First : Typed.T; Count : Rx_Natural) return Typed.Observable; 10 | 11 | function From_Slice (First, Last : Typed.T) return Typed.Observable; 12 | -- Might not emit anything if Last < First 13 | 14 | end Rx.Src.Ranges; 15 | -------------------------------------------------------------------------------- /src/priv/rx-src-start.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | package Rx.Src.Start is 6 | 7 | function Create (Func : Typed.Actions.TFunc0'Class) return Typed.Observable; 8 | -- Will emit the result of Func.Get 9 | 10 | end Rx.Src.Start; 11 | -------------------------------------------------------------------------------- /src/priv/rx-src-timer.ads: -------------------------------------------------------------------------------- 1 | with Rx.Schedulers; 2 | with Rx.Impl.Typed; 3 | 4 | generic 5 | with package Typed is new Rx.Impl.Typed (<>); -- Items emitted 6 | package Rx.Src.Timer with Elaborate_Body is 7 | 8 | function Create (V : Typed.T; 9 | After : Duration; 10 | Scheduler : Schedulers.Scheduler := Schedulers.Computation) 11 | return Typed.Observable; 12 | 13 | end Rx.Src.Timer; 14 | -------------------------------------------------------------------------------- /src/priv/rx-src.ads: -------------------------------------------------------------------------------- 1 | package Rx.Src with Pure is 2 | 3 | end Rx.Src; 4 | -------------------------------------------------------------------------------- /src/priv/rx-tools-holders.ads: -------------------------------------------------------------------------------- 1 | private with Ada.Finalization; 2 | -- with Ada.Containers.Indefinite_Holders; 3 | -- with Ada.Containers.Indefinite_Doubly_Linked_Lists; 4 | -- This is a workaround for a memory leak in the Indefinite_Holders (as of GPL2016) 5 | -- It turns out Lists are broken too in instantiation from rx-from.adb 6 | -- Rolling out my own holders (probably buggy too, or inefficient, or whatever...) 7 | 8 | generic 9 | type Indef (<>) is private; 10 | Id : String := "anonymous holder"; -- Debug purposes only 11 | package Rx.Tools.Holders with Preelaborate is 12 | 13 | type Indef_Access is access Indef; 14 | -- for Indef_Access'Storage_Pool use Debug.Debug_Pool; 15 | 16 | type Definite is tagged private; 17 | 18 | type Reference (Actual : access Indef) is limited null record 19 | with Implicit_Dereference => Actual; 20 | type Const_Ref (Actual : access constant Indef) is limited null record 21 | with Implicit_Dereference => Actual; 22 | 23 | function "+" (I : Indef) return Definite; 24 | function "+" (D : Definite) return Indef; 25 | 26 | function Get (D : Definite) return Indef renames "+"; 27 | 28 | procedure Hold (D : in out Definite; I : Indef); 29 | function Hold (I : Indef) return Definite renames "+"; 30 | 31 | function Ref (D : in out Definite) return Reference; -- bug workaround 32 | function CRef (D : Definite) return Const_Ref; 33 | 34 | function Is_Empty (D : Definite) return Boolean; 35 | 36 | function Is_Valid (D : Definite) return Boolean is (not Is_Empty (D)); 37 | 38 | procedure Clear (D : in out Definite); 39 | -- Dispose of the stored definite 40 | 41 | private 42 | 43 | use Ada.Finalization; 44 | 45 | type Definite is new Ada.Finalization.Controlled with record 46 | Actual : Indef_Access; 47 | end record; 48 | 49 | overriding procedure Initialize (D : in out Definite); 50 | overriding procedure Adjust (D : in out Definite); 51 | overriding procedure Finalize (D : in out Definite); 52 | 53 | procedure Clear (D : in out Definite) renames Finalize; 54 | 55 | function "+" (D : Definite) return Indef is (D.Actual.all); 56 | 57 | function Is_Empty (D : Definite) return Boolean is (D.Actual = null); 58 | 59 | end Rx.Tools.Holders; 60 | -------------------------------------------------------------------------------- /src/priv/rx-tools-lazies.ads: -------------------------------------------------------------------------------- 1 | private with Ada.Finalization; 2 | 3 | generic 4 | type Content is limited private; -- Must have proper defaults 5 | type Ptr is access Content; 6 | package Rx.Tools.Lazies is 7 | 8 | -- Protected wrapper around a type that is created on first use 9 | type Lazy is tagged limited private; 10 | 11 | function Get (This : in out Lazy) return Ptr; 12 | 13 | private 14 | 15 | protected type Safes (Parent : access Lazy) is 16 | procedure Get (X : in out Ptr); 17 | procedure Free; 18 | private 19 | Instance : Ptr; 20 | end Safes; 21 | 22 | use Ada.Finalization; 23 | 24 | type Lazy is new Limited_Controlled with record 25 | Safe : Safes (Lazy'Access); 26 | end record; 27 | 28 | overriding procedure Finalize (This : in out Lazy); 29 | 30 | end Rx.Tools.Lazies; 31 | -------------------------------------------------------------------------------- /src/priv/rx-tools-semaphores.ads: -------------------------------------------------------------------------------- 1 | private with Ada.Finalization; 2 | private with Ada.Task_Identification; 3 | 4 | private with Rx.Tools.Shared_Data; 5 | 6 | private with System.Address_Image; 7 | 8 | package Rx.Tools.Semaphores is 9 | 10 | type Shared is private; 11 | -- A ref-counted semaphore which is initially invalid 12 | 13 | function Create_Reentrant (Fake : Boolean := False) return Shared; 14 | -- Allocate an available semaphore (or a fake one that does nothing) 15 | 16 | type Critical_Section (Mutex : access Shared) is tagged limited private; 17 | -- Declare an instance of this type in the scope to be made exclusive 18 | -- It automatically seizes/releases the semaphore on entering/exiting the scope of declaration 19 | -- The mutex is copied and could be disposed of by the caller inside the critical section 20 | 21 | function Image (This : Shared) return String; 22 | 23 | function Image (This : Critical_Section) return String is 24 | (Image (This.Mutex.all)); 25 | 26 | private 27 | 28 | protected type Reentrant is 29 | entry Seize; 30 | procedure Release; 31 | private 32 | entry Wait; 33 | Count : Natural := 0; 34 | Owner :Ada.Task_Identification.Task_Id := Ada.Task_Identification.Null_Task_Id; 35 | end Reentrant; 36 | 37 | type Reentrant_Ptr is access Reentrant; 38 | 39 | package Shared_Semaphores is new Rx.Tools.Shared_Data (Reentrant, Reentrant_Ptr); 40 | 41 | type Shared is new Shared_Semaphores.Proxy with record 42 | Fake : Boolean := False; 43 | end record; 44 | 45 | not overriding procedure Seize (This : in out Shared); 46 | 47 | not overriding procedure Release (This : in out Shared); 48 | 49 | overriding function Wrap (I : not null Reentrant_Ptr) return Shared is 50 | (Shared_Semaphores.Wrap (I) with Fake => False); 51 | 52 | function Create_Reentrant (Fake : Boolean := False) return Shared is 53 | (if Fake then 54 | (Shared_Semaphores.Proxy with Fake => True) 55 | else 56 | (Wrap (new Reentrant))); 57 | 58 | function Image (This : Shared) return String is 59 | ("#" & System.Address_Image (This.Get.Actual.all'Address)); 60 | 61 | type Critical_Section (Mutex : not null access Shared) is new Ada.Finalization.Limited_Controlled 62 | with record 63 | Sem : Shared; 64 | end record; 65 | 66 | overriding procedure Initialize (This : in out Critical_Section); 67 | overriding procedure Finalize (This : in out Critical_Section); 68 | 69 | end Rx.Tools.Semaphores; 70 | -------------------------------------------------------------------------------- /src/priv/rx-tools.ads: -------------------------------------------------------------------------------- 1 | package Rx.Tools with Pure is 2 | 3 | -- Root for helper packages not directly related to RX 4 | -- These are good candidates to move to a external library 5 | 6 | end Rx.Tools; 7 | -------------------------------------------------------------------------------- /src/priv/rx-traits-arrays.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | generic 4 | with package Typed is new Rx.Impl.Typed (<>); 5 | 6 | type Indexes is (<>); 7 | package Rx.Traits.Arrays is 8 | 9 | -- pragma Preelaborate; 10 | 11 | type Typed_Array is array (Indexes range <>) of Typed.Type_Traits.D; 12 | 13 | Empty_Array : constant Typed_Array; 14 | 15 | -- HERESY TO AVOID FORCING THE USER TO DESIGNATE A NULL VALUE 16 | 17 | function Build (V1 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 18 | function Build (V1, V2 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 19 | function Build (V1, V2, V3 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 20 | function Build (V1, V2, V3, V4 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 21 | function Build (V1, V2, V3, V4, V5 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 22 | function Build (V1, V2, V3, V4, V5, V6 : Typed.T; More : Typed_Array := Empty_Array) return Typed_Array; 23 | 24 | private 25 | 26 | Empty_Array : constant Typed_Array (Indexes'Succ (Indexes'First) .. Indexes'First) := (others => <>); 27 | 28 | end Rx.Traits.Arrays; 29 | -------------------------------------------------------------------------------- /src/priv/rx-traits-definite_defaults.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Types; 2 | 3 | generic 4 | type T is private; -- User type that is already definite; 5 | package Rx.Traits.Definite_Defaults is 6 | 7 | type D is new T; 8 | 9 | function To_Definite (V : T) return D is (D (V)); 10 | function To_Indefinite (V : D) return T is (T (V)); 11 | 12 | package Type_Traits is new Traits.Types (T, D); 13 | 14 | end Rx.Traits.Definite_Defaults; 15 | -------------------------------------------------------------------------------- /src/priv/rx-traits-indefinite_defaults.ads: -------------------------------------------------------------------------------- 1 | with Rx.Tools.Holders; 2 | with Rx.Traits.Types; 3 | 4 | generic 5 | type T (<>) is private; -- User type that is not definite; 6 | package Rx.Traits.Indefinite_Defaults is 7 | 8 | package Holders is new Rx.Tools.Holders (T, "indefinite_defaults.T"); 9 | 10 | type D is new Holders.Definite with null record; 11 | 12 | -- function To_Definite (V : T) return D renames "+"; 13 | -- function To_Indefinite (V : D) return T renames "+"; 14 | 15 | package Type_Traits is new Traits.Types (T, D, Hold, Get); 16 | 17 | end Rx.Traits.Indefinite_Defaults; 18 | -------------------------------------------------------------------------------- /src/priv/rx-traits-iterable.ads: -------------------------------------------------------------------------------- 1 | with Rx.Impl.Typed; 2 | 3 | pragma Warnings (Off); 4 | 5 | generic 6 | with package Typed is new Rx.Impl.Typed (<>); 7 | type Container is private; 8 | with procedure Iterate (C : Container; Proc : access procedure (V : Typed.T)) is <>; 9 | -- Iterate should call its second parameter procedure for each element in the container 10 | package Rx.Traits.Iterable with Preelaborate is 11 | 12 | end Rx.Traits.Iterable; 13 | -------------------------------------------------------------------------------- /src/priv/rx-traits.ads: -------------------------------------------------------------------------------- 1 | -- Root package for policies/traits 2 | package Rx.Traits is 3 | 4 | pragma Pure; 5 | 6 | type Printable is interface; 7 | function Image (P : Printable) return String is abstract; 8 | 9 | end Rx.Traits; 10 | -------------------------------------------------------------------------------- /src/rx-actions-transform.ads: -------------------------------------------------------------------------------- 1 | with Rx.Contracts; 2 | 3 | generic 4 | with package From is new Rx.Contracts (<>); 5 | with package Into is new Rx.Contracts (<>); 6 | package Rx.Actions.Transform with Preelaborate is 7 | 8 | -- Plain type transforming functions 9 | 10 | type Func1 is access function (V : From.T) return Into.T; 11 | 12 | type Func2 is access function (F : From.T; 13 | I : Into.T) return Into.T; 14 | 15 | -- FlatMap infrastructure 16 | 17 | type Inflater1 is access function (V : From.T) return Into.Observable'Class; 18 | 19 | type TInflater1 is interface; 20 | function Evaluate (Func : TInflater1; V : From.T) return Into.Observable'Class is abstract; 21 | 22 | function Wrap (Func : Inflater1) return TInflater1'Class; 23 | 24 | package TInflater1_Holders is new Tools.Holders (TInflater1'Class); 25 | type HInflater1 is new TInflater1_Holders.Definite with null record; 26 | 27 | private 28 | 29 | type Inflater1_Wrapper (Func : Inflater1) is new TInflater1 with null record; 30 | 31 | overriding function Evaluate (Func : Inflater1_Wrapper; V : From.T) return Into.Observable'Class is 32 | (Func.Func (V)); 33 | 34 | function Wrap (Func : Inflater1) return TInflater1'Class is 35 | (Inflater1_Wrapper'(Func => Func)); 36 | 37 | end Rx.Actions.Transform; 38 | -------------------------------------------------------------------------------- /src/rx-actions-typed.ads: -------------------------------------------------------------------------------- 1 | generic 2 | type T (<>) is private; 3 | package Rx.Actions.Typed with Preelaborate is 4 | 5 | type Func0 is access function return T; 6 | type TFunc0 is interface; 7 | function Get (Func : in out TFunc0) return T is abstract; 8 | function Wrap (Func : Func0) return TFunc0'Class; 9 | 10 | type Func1 is access function (V : T) return T; 11 | 12 | type Func1Str is access function (V : T) return String; 13 | type TFunc1Str is interface; 14 | function Convert (Func : in out TFunc1Str; V : T) return String is abstract; 15 | function Wrap (Func : Func1Str) return TFunc1Str'Class; 16 | 17 | type Proc1 is access procedure (V : T); 18 | type TProc1 is interface; 19 | procedure Call (Proc : in out TProc1; V : T) is abstract; 20 | function Wrap (Proc : Proc1) return TProc1'Class; 21 | 22 | type Filter1 is access function (V : T) return Boolean; 23 | type TFilter1 is interface; 24 | function Check (Filter : in out TFilter1; V : T) return Boolean is abstract; 25 | function Wrap (Filter : Filter1) return TFilter1'Class; 26 | 27 | type Comparator is access function (L, R : T) return Boolean; 28 | 29 | -- Holders 30 | 31 | package Func0_Holders is new Rx.Tools.Holders (TFunc0'Class, "func0"); 32 | type HTFunc0 is new Func0_Holders.Definite with null record; 33 | 34 | package Func1Str_Holders is new Rx.Tools.Holders (TFunc1Str'Class, "func1str"); 35 | type HTFunc1Str is new Func1Str_Holders.Definite with null record; 36 | 37 | package Filter1_Holders is new Rx.Tools.Holders (TFilter1'Class, "filter1"); 38 | type HTFilter1 is new Filter1_Holders.Definite with null record; 39 | 40 | package Proc1_Holders is new Rx.Tools.Holders (TProc1'Class, "proc1"); 41 | type HTProc1 is new Proc1_Holders.Definite with null record; 42 | 43 | -- Predefined actions 44 | 45 | function Always_Pass return TFilter1'Class; 46 | -- Trivial filter that always returns true 47 | 48 | function Countdown (Times : Rx_Natural) return TFilter1'Class; 49 | -- Filter that passes Times times and then fails forever 50 | 51 | function "not" (Filter : TFilter1'Class) return TFilter1'Class; 52 | function "not" (Filter : Filter1) return TFilter1'Class; 53 | -- Negates the result of some filter 54 | 55 | function Negate (Filter : TFilter1'Class) return TFilter1'Class renames "not"; 56 | 57 | private 58 | 59 | function Always_True (Unused : T) return Boolean is (True); 60 | 61 | function Always_Pass return TFilter1'Class is (Wrap (Always_True'Access)); 62 | 63 | function "not" (Filter : Filter1) return TFilter1'Class is 64 | (Negate (Wrap (Filter))); 65 | 66 | end Rx.Actions.Typed; 67 | -------------------------------------------------------------------------------- /src/rx-actions.ads: -------------------------------------------------------------------------------- 1 | with Rx.Errors; 2 | with Rx.Tools.Holders; 3 | 4 | package Rx.Actions with Preelaborate is 5 | 6 | -- Procedures/Actions that do not require a type 7 | 8 | type Inspector is access 9 | procedure (Event_Kind : Rx_Event_Kinds; 10 | Since_Previous : Duration; 11 | Since_Subscription : Duration); 12 | 13 | type Proc0 is access procedure; 14 | type Proc_Error is access procedure (E : Errors.Occurrence); 15 | type TProc0 is interface; 16 | procedure Run (Proc : in out TProc0) is abstract; 17 | function Wrap (Proc : Proc0) return TProc0'Class; 18 | 19 | type Filter0 is access function return Boolean; 20 | type TFilter0 is interface; 21 | function Check (Filter : in out TFilter0) return Boolean is abstract; 22 | function Wrap (Check : Filter0) return TFilter0'Class; 23 | 24 | -- Holders for the tagged variants follow 25 | 26 | package Proc0_Holders is new Rx.Tools.Holders (TProc0'Class); 27 | type HTProc0 is new Proc0_Holders.Definite with null record; 28 | 29 | package Filter0_Holders is new Rx.Tools.Holders (TFilter0'Class); 30 | type HTFilter0 is new Filter0_Holders.Definite with null record; 31 | 32 | -- Predefined actions follow 33 | 34 | function Count (Times : Positive) return TFilter0'Class; 35 | -- At and after the Times-nth call it will return true 36 | -- E.g. for Times = 3, Check returns False, False, True 37 | 38 | function "not" (Filter : TFilter0'Class) return TFilter0'Class; 39 | -- Negates the result of some filter 40 | 41 | function Negate (Filter : TFilter0'Class) return TFilter0'Class renames "not"; 42 | 43 | end Rx.Actions; 44 | -------------------------------------------------------------------------------- /src/rx-collections.ads: -------------------------------------------------------------------------------- 1 | with Ada.Containers.Indefinite_Doubly_Linked_Lists; 2 | 3 | with Rx.Impl.Preservers; 4 | with Rx.Traits.Types; 5 | with Rx.Impl.Transformers; 6 | with Rx.Impl.Typed; 7 | with Rx.Valueless; 8 | 9 | generic 10 | with package Typed is new Rx.Impl.Typed (<>); 11 | package Rx.Collections is 12 | 13 | -- Instances of types and transformations that we get automatically when creating a new Rx type 14 | 15 | ----------------- 16 | -- Valueless -- 17 | ----------------- 18 | 19 | package Valueless is new Impl.Transformers (Typed, Valueless.Typed); 20 | 21 | ------------------------- 22 | -- Emission of Lists -- 23 | ------------------------- 24 | 25 | package Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists (Typed.T, Typed.Type_Traits."="); 26 | subtype List is Lists.List; 27 | 28 | function Identity (L : List) return List is (L); 29 | 30 | package List_Traits is new Rx.Traits.Types (List, List, Identity, Identity); 31 | package Typed_Lists is new Rx.Impl.Typed (List_Traits); 32 | 33 | ------------------------------- 34 | -- Emission of observables -- 35 | ------------------------------- 36 | 37 | package Observable_Traits is new Rx.Traits.Types (Typed.Contracts.Observable'Class, 38 | Typed.Definite_Observables.Observable, 39 | Typed.Definite_Observables.From, 40 | Typed.Definite_Observables.To_Indef); 41 | 42 | package Typed_Observables is new Rx.Impl.Typed (Observable_Traits); 43 | 44 | ----------------- 45 | -- Operators -- 46 | ----------------- 47 | 48 | package List_Preservers is new Rx.Impl.Preservers (Typed_Lists); 49 | package Into_List_Transformers is new Rx.Impl.Transformers (Typed, Typed_Lists); 50 | package From_List_Transformers is new Rx.Impl.Transformers (Typed_Lists, Typed); 51 | 52 | package Obs_Transformers is new Rx.Impl.Transformers (Typed, Typed_Observables); 53 | 54 | end Rx.Collections; 55 | -------------------------------------------------------------------------------- /src/rx-contracts.ads: -------------------------------------------------------------------------------- 1 | -- Interfaces that rule the Rx world 2 | 3 | with Rx.Errors; 4 | with Rx.Subscribers; 5 | with Rx.Subscriptions; 6 | 7 | generic 8 | type T (<>) is private; 9 | package Rx.Contracts is 10 | 11 | pragma Preelaborate; 12 | 13 | -------------- 14 | -- Observer -- 15 | -------------- 16 | 17 | type Observer is interface; 18 | -- Someone interested in receiving data 19 | 20 | procedure On_Next (This : in out Observer; V : T) is abstract; 21 | procedure On_Complete (This : in out Observer) is abstract; 22 | procedure On_Error (This : in out Observer; Error : Errors.Occurrence) is abstract; 23 | 24 | ---------------- 25 | -- Observable -- 26 | ---------------- 27 | 28 | type Observable is interface; 29 | -- Someone capable of producing data to which an observer can subscribe 30 | 31 | procedure Subscribe (Producer : in out Observable; 32 | Consumer : in out Observer'Class) is abstract; 33 | 34 | ---------------- 35 | -- Subscriber -- 36 | ---------------- 37 | 38 | subtype Subscriber is Subscribers.Subscriber; 39 | 40 | ---------- 41 | -- Sink -- 42 | ---------- 43 | 44 | -- Final Endpoint for a live chain 45 | type Sink is abstract new Observer and Subscribers.Subscriber with private; 46 | -- A sink is someone who requested a subscription and consumes data, 47 | -- as opposed to an operator that passes data along. 48 | 49 | overriding function Is_Subscribed (This : Sink) return Boolean; 50 | 51 | overriding procedure On_Complete (This : in out Sink); 52 | -- Call this if overrinding it 53 | 54 | not overriding 55 | procedure Set_Subscription (This : in out Sink; S : Subscriptions.Subscription); 56 | -- A sink receives a subscription at the moment of being subscribed 57 | 58 | overriding procedure Unsubscribe (This : in out Sink); 59 | 60 | --------------- 61 | -- Subscribe -- 62 | --------------- 63 | 64 | function Subscribe (Producer : Observable'Class; Consumer : Sink'Class) return Subscriptions.Subscription; 65 | -- Execute the subscription 66 | 67 | private 68 | 69 | type Sink is abstract new Observer and Subscribers.Subscriber with record 70 | Subscription : Subscriptions.Subscription; 71 | end record; 72 | 73 | overriding function Is_Subscribed (This : Sink) return Boolean is 74 | (This.Subscription.Is_Subscribed); 75 | 76 | end Rx.Contracts; 77 | -------------------------------------------------------------------------------- /src/rx-conversions.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Types; 2 | 3 | generic 4 | with package Type_Traits is new Rx.Traits.Types (<>); 5 | package Rx.Conversions with Preelaborate is 6 | 7 | subtype D is Type_Traits.D; 8 | subtype T is Type_Traits.T; 9 | 10 | function "=" (L, R : T) return Boolean renames Type_Traits."="; 11 | 12 | function "+" (V : T) return D renames Type_Traits.To_Definite; 13 | function "+" (V : D) return T renames Type_Traits.To_Indefinite; 14 | 15 | function Def (V : T) return D renames Type_Traits.To_Definite; 16 | function Ind (V : D) return T renames Type_Traits.To_Indefinite; 17 | 18 | end Rx.Conversions; 19 | -------------------------------------------------------------------------------- /src/rx-defaults.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | 3 | with Rx.Contracts; 4 | with Rx.Errors; 5 | 6 | generic 7 | with package Contracts is new Rx.Contracts (<>); 8 | package Rx.Defaults with Preelaborate is 9 | 10 | -- Defaults to be used elsewhere 11 | 12 | procedure Default_Error_Handler (This : in out Contracts.Observer'Class; 13 | Except : Ada.Exceptions.Exception_Occurrence); 14 | -- Calls down On_Error for non-critical exceptions, otherwise raises 15 | -- If no downstream, just report 16 | 17 | procedure Default_On_Error (E : Errors.Occurrence); 18 | -- Dump error to console and re-raise 19 | 20 | type Observer is new Contracts.Observer with null record; 21 | -- Does nothing but properly reporting in On_Error 22 | 23 | overriding procedure On_Next (This : in out Observer; V : Contracts.T) is null; 24 | 25 | overriding procedure On_Complete (This : in out Observer) is null; 26 | 27 | overriding procedure On_Error (This : in out Observer; 28 | E : Errors.Occurrence); 29 | 30 | end Rx.Defaults; 31 | -------------------------------------------------------------------------------- /src/rx-definites.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Definite_Defaults; 2 | with Rx.Types; 3 | 4 | -- Entry point for a user to declare a new type to be used in Rx chains 5 | generic 6 | type T is private; 7 | package Rx.Definites is 8 | 9 | -- Preparation instances 10 | package Defaults is new Rx.Traits.Definite_Defaults (T); 11 | package Instance is new Rx.Types (Defaults.Type_Traits); 12 | 13 | -- Actually usable package 14 | package Observables renames Instance.Observables; 15 | 16 | -- Other shortcuts 17 | package Contracts renames Instance.Typed.Contracts; 18 | 19 | subtype Observable is Instance.Observable; 20 | 21 | end Rx.Definites; 22 | -------------------------------------------------------------------------------- /src/rx-errors.ads: -------------------------------------------------------------------------------- 1 | with Ada.Exceptions; 2 | with Ada.Finalization; 3 | 4 | package Rx.Errors is 5 | 6 | pragma Preelaborate; 7 | 8 | type Occurrence is tagged private; 9 | 10 | procedure Fill (Error : out Occurrence; 11 | From : Ada.Exceptions.Exception_Occurrence); 12 | 13 | function Create (From : Ada.Exceptions.Exception_Occurrence) return Occurrence; 14 | 15 | procedure Reraise (Error : Occurrence); 16 | 17 | function Get_Exception (Error : Occurrence) 18 | return access constant Ada.Exceptions.Exception_Occurrence; 19 | 20 | private 21 | 22 | type Except_Access is access Ada.Exceptions.Exception_Occurrence; 23 | 24 | type Occurrence is new Ada.Finalization.Controlled with record 25 | Instance : Except_Access; 26 | end record; 27 | 28 | overriding procedure Finalize (E : in out Occurrence); 29 | overriding procedure Adjust (E : in out Occurrence); 30 | 31 | function Get_Exception (Error : Occurrence) 32 | return access constant Ada.Exceptions.Exception_Occurrence 33 | is (Error.Instance); 34 | 35 | end Rx.Errors; 36 | -------------------------------------------------------------------------------- /src/rx-factories.ads: -------------------------------------------------------------------------------- 1 | with Rx.Contracts; 2 | 3 | generic 4 | with package Contracts is new Rx.Contracts (<>); 5 | package Rx.Factories with Preelaborate is 6 | 7 | type Observable_Factory is interface; 8 | 9 | function Subscribe (F : Observable_Factory) return Contracts.Observable'Class is abstract; 10 | 11 | type Observable_Factory_Func is access function return Contracts.Observable'Class; 12 | 13 | end Rx.Factories; 14 | -------------------------------------------------------------------------------- /src/rx-indefinites.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Indefinite_Defaults; 2 | with Rx.Types; 3 | 4 | -- Entry point for a user to declare a new type to be used in Rx chains 5 | generic 6 | type T (<>) is private; 7 | package Rx.Indefinites is 8 | 9 | -- Preparation instances 10 | package Defaults is new Rx.Traits.Indefinite_Defaults (T); 11 | package Instance is new Rx.Types (Defaults.Type_Traits); 12 | 13 | -- Actually usable package 14 | package Observables renames Instance.Observables; 15 | 16 | -- Other shortcuts 17 | package Actions renames Instance.Typed.Actions; 18 | package Contracts renames Instance.Typed.Contracts; 19 | 20 | subtype Observable is Instance.Observable; 21 | 22 | -- For easy visibility of this heresy: 23 | package Arrays renames Observables.Default_Arrays; 24 | 25 | end Rx.Indefinites; 26 | -------------------------------------------------------------------------------- /src/rx-numeric_operators.ads: -------------------------------------------------------------------------------- 1 | with Rx.Operators; 2 | 3 | private with Rx.Op.Count; 4 | private with Rx.Op.Length; 5 | 6 | generic 7 | with package Operators is new Rx.Operators (<>); 8 | with function To_Numeric (I : Rx_Integer) return Operators.Into.T; 9 | with function Succ (V : Operators.Into.T) return Operators.Into.T; 10 | package Rx.Numeric_Operators is 11 | 12 | package From renames Operators.From; 13 | package Into renames Operators.Into; 14 | 15 | package Transformers renames Operators.Typed; 16 | package From_List_Transformers renames Operators.Typed_Lists; 17 | 18 | subtype Operator is Transformers.Operator'Class; 19 | 20 | function Count (First : Into.T := To_Numeric (0)) return Operator; 21 | 22 | function Count (First : Into.T := To_Numeric (0)) return From_List_Transformers.Operator'Class; 23 | 24 | function Length return From_List_Transformers.Operator'Class; 25 | 26 | private 27 | 28 | function List_Length (L : From.T_List) return Into.T is 29 | (To_Numeric (Rx_Integer (L.Length))); 30 | 31 | package RxCount is new Rx.Op.Count (Transformers, Succ, To_Numeric (0)); 32 | package RxCountLists is new Rx.Op.Count (From_List_Transformers, Succ, To_Numeric (0)); 33 | package RxLength is new Rx.Op.Length (From_List_Transformers, List_Length); 34 | 35 | function Count (First : Into.T := To_Numeric (0)) return Operator renames RxCount.Count; 36 | 37 | function Count (First : Into.T := To_Numeric (0)) 38 | return From_List_Transformers.Operator'Class renames RxCountLists.Count; 39 | 40 | function Length return From_List_Transformers.Operator'Class renames RxLength.Create; 41 | 42 | end Rx.Numeric_Operators; 43 | -------------------------------------------------------------------------------- /src/rx-observables-image.ads: -------------------------------------------------------------------------------- 1 | generic 2 | with function Image (V : T) return String is <>; 3 | package Rx.Observables.Image is 4 | 5 | function List_Image (L : T_List) return String; 6 | -- A default style of "(x, y, z, ...)" 7 | 8 | function Print (With_Timestamp : Boolean := True) return Operator; 9 | 10 | function Print (With_Timestamp : Boolean := True) return List_Preserver; 11 | 12 | private 13 | 14 | function Addressable_Image (V : T) return String; 15 | -- For some reason, Image can be used directly 16 | -- Additionally, a gnat bug precludes using a expression function for this body 17 | 18 | function Print (With_Timestamp : Boolean := True) return Operator is 19 | (Observables.Print (Addressable_Image'Access, With_Timestamp)); 20 | 21 | package RxPrintList is new Rx.Op.Print (List_Preservers); 22 | 23 | function Print (With_Timestamp : Boolean := True) return List_Preserver is 24 | (RxPrintList.Create (List_Image'Access, With_Timestamp)); 25 | 26 | end Rx.Observables.Image; 27 | -------------------------------------------------------------------------------- /src/rx-schedulers-pools.ads: -------------------------------------------------------------------------------- 1 | with Rx.Dispatchers.Pools; 2 | 3 | package Rx.Schedulers.Pools is 4 | 5 | type Pool (<>) is limited new Schedulers.Pool with private; 6 | -- Custom pool that will create as much as Size (see below) threads for use 7 | 8 | function Create (Size : Positive; Name : String := "") return Pool; 9 | 10 | function Get_Next (This : in out Pool) return Thread; 11 | -- Round-robin use of threads 12 | 13 | function Get_Idle (This : in out Pool) return Thread; 14 | -- Get first idle (O(N)) thread or next busy 15 | 16 | overriding function Get_Thread (This : in out Pool) return Thread 17 | renames Get_Next; 18 | 19 | private 20 | 21 | type Pool is limited new Dispatchers.Pools.Pool and Schedulers.Pool with null record; 22 | 23 | function Get_Next (This : in out Pool) return Thread is 24 | (Thread (This.Get (Reuse => False))); 25 | 26 | function Get_Idle (This : in out Pool) return Thread is 27 | (Thread (This.Find_Idle (Grow => False))); 28 | 29 | end Rx.Schedulers.Pools; 30 | -------------------------------------------------------------------------------- /src/rx-subjects.ads: -------------------------------------------------------------------------------- 1 | with Rx.Errors; 2 | with Rx.Impl.Transformers; 3 | 4 | generic 5 | with package Transformer is new Rx.Impl.Transformers (<>); 6 | package Rx.Subjects with Preelaborate is 7 | 8 | -- Subjects are both observable and observer, with state 9 | 10 | type Subject Is 11 | new Transformer.From.Contracts.Observer 12 | and Transformer.Into.Contracts.Observable with private; 13 | 14 | overriding procedure On_Next (This : in out Subject; V : Transformer.From.T) is null; 15 | overriding procedure On_Complete (This : in out Subject) is null; 16 | overriding procedure On_Error (This : in out Subject; Error : Errors.Occurrence) is null; 17 | 18 | overriding procedure Subscribe (Producer : in out Subject; 19 | Consumer : in out Transformer.Into.Observer'Class) is null; 20 | 21 | private 22 | 23 | type Subject Is 24 | new Transformer.From.Contracts.Observer 25 | and Transformer.Into.Contracts.Observable with null record; 26 | 27 | end Rx.Subjects; 28 | -------------------------------------------------------------------------------- /src/rx-subscribe.ads: -------------------------------------------------------------------------------- 1 | with Rx.Actions; 2 | with Rx.Errors; 3 | with Rx.Impl.Typed; 4 | 5 | generic 6 | with package Typed is new Rx.Impl.Typed (<>); 7 | package Rx.Subscribe is 8 | 9 | pragma Preelaborate; 10 | 11 | type Proc_Error is access procedure (E : Errors.Occurrence); 12 | -- Needed to circumvent a forbidden 'Access use (RM 3.10.2(32)) 13 | 14 | function Create (On_Next : Typed.Actions.Proc1 := null; 15 | On_Complete : Rx.Actions.Proc0 := null; 16 | On_Error : Proc_Error := Typed.Defaults.Default_On_Error'Access) 17 | return Typed.Contracts.Sink'Class; 18 | 19 | function Create (Using : Typed.Observer'Class) return Typed.Sink; 20 | -- Wraps an observer into a Sink, providing subscription management 21 | -- See Typed.Defaults.Observer for a possible base implementation 22 | 23 | private 24 | 25 | -- Either the access to procedures are used (hence the class was created by Create) 26 | -- or the held observer is valid 27 | 28 | type Subscribe is new Typed.Contracts.Sink with record 29 | Func_On_Next : Typed.Actions.Proc1; 30 | Func_On_Complete : Rx.Actions.Proc0; 31 | Func_On_Error : Proc_Error; 32 | 33 | Observer : Typed.Holders.Observer; 34 | 35 | Completed : Boolean := False; 36 | Errored : Boolean := False; 37 | end record; 38 | 39 | overriding procedure On_Next (This : in out Subscribe; V : Typed.T); 40 | overriding procedure On_Complete (This : in out Subscribe); 41 | overriding procedure On_Error (This : in out Subscribe; Error : Errors.Occurrence); 42 | 43 | end Rx.Subscribe; 44 | -------------------------------------------------------------------------------- /src/rx-subscribers.ads: -------------------------------------------------------------------------------- 1 | package Rx.Subscribers with Pure is 2 | 3 | type Subscriber is interface; 4 | 5 | procedure Unsubscribe (S : in out Subscriber) is abstract; 6 | 7 | function Is_Subscribed (S : Subscriber) return Boolean is abstract; 8 | 9 | end Rx.Subscribers; 10 | -------------------------------------------------------------------------------- /src/rx-subscriptions.ads: -------------------------------------------------------------------------------- 1 | with Rx.Subscribers; 2 | 3 | private with Rx.Tools.Shared_Data; 4 | 5 | package Rx.Subscriptions is 6 | 7 | pragma Preelaborate; 8 | 9 | type Subscription is new Subscribers.Subscriber with private; 10 | 11 | function Subscribe return Subscription; 12 | 13 | overriding procedure Unsubscribe (S : in out Subscription); 14 | 15 | overriding function Is_Subscribed (S : Subscription) return Boolean; 16 | 17 | -- For when we do not care at all: 18 | 19 | type No_Subscription is null record; 20 | 21 | function "-" (S : Subscription) return No_Subscription is (null record); 22 | 23 | procedure Subscribe (S : Subscription) is null; 24 | 25 | private 26 | 27 | type State is (Subscribed, Unsubscribed); 28 | 29 | type State_Access is access State; 30 | 31 | -- This probably can be done more lightweight since it involves a single boolean check 32 | package Shared_Booleans is new Rx.Tools.Shared_Data (State, State_Access); 33 | 34 | type Subscription is new Shared_Booleans.Proxy and Subscribers.Subscriber with null record; 35 | 36 | overriding function Is_Subscribed (S : Subscription) return Boolean is (S.Is_Valid and then S.Get = Subscribed); 37 | 38 | function Subscribe return Subscription is (Wrap (new State'(Subscribed))); 39 | 40 | end Rx.Subscriptions; 41 | -------------------------------------------------------------------------------- /src/rx-traits-types.ads: -------------------------------------------------------------------------------- 1 | pragma Warnings (Off); 2 | 3 | generic 4 | type T (<>) is private; -- The user-facing type 5 | type D is private; -- Definite type for storage of T 6 | with function To_Definite (V : T) return D is <>; 7 | with function To_Indefinite (V : D) return T is <>; 8 | package Rx.Traits.Types with Preelaborate is 9 | 10 | -- function "+" (V : T) return D renames To_Definite; 11 | -- function "-" (V : D) return T renames To_Indefinite; 12 | 13 | end Rx.Traits.Types; 14 | -------------------------------------------------------------------------------- /src/rx-types.ads: -------------------------------------------------------------------------------- 1 | with Rx.Observables; 2 | with Rx.Traits.Types; 3 | with Rx.Impl.Typed; 4 | 5 | -- Entry point for a user to declare a new Rx-processed type, with full traits control 6 | -- For simpler instantiations take a look at Rx.Definites and Rx.Indefinites 7 | generic 8 | with package Type_Traits is new Rx.Traits.Types (<>); 9 | package Rx.Types is 10 | 11 | -- This is the parametric package to instance other packages provided by Rx 12 | -- Not usually needed if using Rx.Std or default Observables 13 | package Typed is new Rx.Impl.Typed (Type_Traits); 14 | 15 | -- This is the package to be used in plain user code 16 | package Observables is new Rx.Observables (Typed); 17 | 18 | subtype Observable is Typed.Contracts.Observable'Class; 19 | 20 | end Rx.Types; 21 | -------------------------------------------------------------------------------- /src/rx-valueless.ads: -------------------------------------------------------------------------------- 1 | with Rx.Traits.Types; 2 | with Rx.Impl.Typed; 3 | 4 | package Rx.Valueless with Preelaborate is 5 | 6 | Subtype Nothing is Rx_Nothing; 7 | 8 | function To_Definite (V : Nothing) return Nothing is (V); 9 | function To_Indefinite (V : Nothing) return Nothing is (V); 10 | 11 | package Traits is new Rx.Traits.Types (Nothing, Nothing); 12 | 13 | package Typed is new Rx.Impl.Typed (Traits); 14 | 15 | subtype Observable is Typed.Observable; 16 | 17 | end Rx.Valueless; 18 | -------------------------------------------------------------------------------- /src/rx.ads: -------------------------------------------------------------------------------- 1 | pragma Detect_Blocking; 2 | pragma License (Modified_GPL); 3 | 4 | package Rx with Pure is 5 | 6 | Unimplemented : exception; 7 | -- Used to signal features that are on the roadmap, but not yet completed 8 | 9 | No_Longer_Subscribed : exception; 10 | -- This is the only subscription pervading this design. 11 | -- Generators of data must be aware that this can be raised in any observer call. 12 | 13 | -- The following are defaults for the default operators. 14 | -- Also they are used in operators that take regular numbers as parameters. 15 | -- It is a compromise to eliminate yet another generic parameter which will rarely be meaningul. 16 | -- For specific need the user can create instances for any desired type. 17 | 18 | subtype Rx_Integer is Long_Long_Integer; 19 | subtype Rx_Natural is Rx_Integer range 0 .. Rx_Integer'Last; 20 | subtype Rx_Positive is Rx_Integer range 1 .. Rx_Integer'Last; 21 | 22 | subtype Rx_Float is Long_Long_Float; 23 | 24 | subtype Rx_String is String; 25 | 26 | type Rx_Nothing is null record; 27 | -- Some observables are used for notification purposes, with values of no importance 28 | 29 | -- Other literals of general use 30 | 31 | type Rx_Event_Kinds is 32 | (On_Next, 33 | On_Complete, 34 | On_Error); 35 | 36 | type Merge_Policies is 37 | (Merge, -- Just relay as they come 38 | Sequence, -- Force sequencing of observables 39 | Switch); -- Drop from any previous observable, use only last one 40 | 41 | end Rx; 42 | -------------------------------------------------------------------------------- /src/utests/rx-tests.ads: -------------------------------------------------------------------------------- 1 | -- Explicit test functions, since gnattest mostly fails for generics 2 | 3 | package Rx.Tests is 4 | 5 | function Misc_Tests return Boolean; 6 | 7 | function Operators return Boolean; 8 | 9 | function Subscriptions return Boolean; 10 | 11 | function Sources return Boolean; 12 | 13 | end Rx.Tests; 14 | -------------------------------------------------------------------------------- /trash/bitbucket-pipelines.yml: -------------------------------------------------------------------------------- 1 | # This is a sample build configuration for Other. 2 | # Check our guides at https://confluence.atlassian.com/x/5Q4SMw for more examples. 3 | # Only use spaces to indent your .yml configuration. 4 | # ----- 5 | # You can specify a custom docker image from Docker Hub as your build environment. 6 | 7 | image: reznik/gnat:gpl.2017.slim 8 | 9 | pipelines: 10 | branches: 11 | default: 12 | - step: 13 | script: 14 | - /opt/gnat/bin/gprbuild -p -P rxada_dev --------------------------------------------------------------------------------