package GNATCOLL.Promises is
use type GNATCOLL.Atomic.Atomic_Counter;
subtype Promise_State is GNATCOLL.Atomic.Atomic_Counter;
Pending : constant Promise_State := 0;
Resolved : constant Promise_State := 1;
Failed : constant Promise_State := 2;
Resolving : constant Promise_State := 3;
Failing : constant Promise_State := 4;
Subscribing : constant Promise_State := 5;
subtype Actual_Promise_State is Promise_State range Pending .. Subscribing;
-- The various states that a promise can have.
-- We use atomic operations when possible to manipulate it, to make
-- promises task safe.
type Promise_Chain is tagged private;
procedure Subscribe (Self : Promise_Chain) with Inline => True;
-- A dummy type used when chaining promises with the "and"
-- operator. See below for an example of code.
--
-- Do not mark this procedure as "is null", since otherwise GNAT
-- does not even call the last "and" in the chain.
--------------
-- IFreeable --
--------------
type IFreeable is interface;
type Freeable_Access is access all IFreeable'Class;
-- a general interface for objects that have an explicit Free
-- primitive operation.
procedure Free (Self : in out IFreeable) is null;
-- Free internal data of Self
procedure Free (Self : in out Freeable_Access);
-- Free self, via its primitive operation, and then free the pointer
----------
-- Impl --
----------
-- This package is for implementation details
package Impl is
type IPromise_Data is interface;
procedure Free (Self : in out IPromise_Data) is null;
procedure Dispatch_Free (Self : in out IPromise_Data'Class);
type IAbstract_Promise is interface;
package Promise_Pointers is new GNATCOLL.Refcount.Shared_Pointers
(Element_Type => IPromise_Data'Class,
Release => Dispatch_Free,
Atomic_Counters => True); -- thread-safe
type Root_Promise is
new Promise_Pointers.Ref and IAbstract_Promise with null record;
type IPromise_Callback is interface and IFreeable;
type Promise_Callback_Access is access all IPromise_Callback'Class;
procedure On_Error
(Self : in out IPromise_Callback; Reason : String) is null;
-- Called when a promise has failed and will never be resolved.
end Impl;
--------------
-- Promises --
--------------
generic
type T (<>) is private;
package Promises is
type Promise is new Impl.IAbstract_Promise with private;
-- A promise is a smart pointer: it is a wrapper around shared
-- data that is freed when no more reference to the promise
-- exists.
subtype Result_Type is T;
---------------
-- Callbacks --
---------------
type Callback is interface and Impl.IPromise_Callback;
type Callback_Access is access all Callback'Class;
procedure On_Next (Self : in out Callback; R : Result_Type) is null;
-- Executed when a promise is resolved. It provides the real value
-- associated with the promise.
type Callback_List (<>) is private;
-- Multiple callbacks, all subscribed to the same promise (or
-- will be subscribed to the same promise).
--------------
-- Promises --
--------------
function Create return Promise
with
Post => Create'Result.Is_Created
and Create'Result.Get_State = Pending;
-- Create a new promise, with no associated value.
procedure Set_Value (Self : in out Promise; R : T)
with
Pre => Self.Is_Created
and Self.Get_State /= Resolved
and Self.Get_State /= Failed,
Post => Self.Get_State = Resolved;
-- Give a result to the promise.
-- The callbacks' On_Next methods are executed.
-- This can only be called once on a promise.
procedure Set_Error (Self : in out Promise; Reason : String)
with
Pre => Self.Is_Created
and Self.Get_State /= Resolved
and Self.Get_State /= Failed,
Post => Self.Get_State = Failed;
-- Mark the promise has failed. It will never be resolved.
-- The callbacks' On_Error method are executed.
procedure Subscribe
(Self : Promise;
Cb : not null access Callback'Class)
with Pre => Self.Is_Created;
function "and"
(Self : Promise;
Cb : not null access Callback'Class) return Promise_Chain
with Pre => Self.Is_Created;
function "and"
(Self : Promise; Cb : Callback_List) return Promise_Chain
with Pre => Self.Is_Created;
-- Will call Cb when Self is resolved or failed (or immediately if Self
-- has already been resolved or failed).
-- Any number of callbacks can be set on each promise.
-- If you want to chain promises (i.e. your callback itself returns
-- a promise), take a look at the Chains package below.
--
-- Cb must be allocated specifically for this call, and will be
-- freed as needed. You must not reuse the same pointer for multiple
-- calls to Subscribe.
-- ??? This is unsafe
--
-- Self is modified, but does not need to be "in out" since a promise
-- is a pointer. This means that Subscribe can be directly called on
-- the result of a function call, for instance.
function "&"
(Cb : not null access Callback'Class;
Cb2 : not null access Callback'Class) return Callback_List;
function "&"
(List : Callback_List;
Cb2 : not null access Callback'Class) return Callback_List;
-- Create a list of callbacks that will all be subscribed to the same
-- promise.
function Is_Created
(Self : Promise'Class) return Boolean with Inline;
-- Whether the promise has been created
function Get_State
(Self : Promise'Class) return Actual_Promise_State with Inline;
-- Used for pre and post conditions
private
type Promise is new Impl.Root_Promise with null record;
type Callback_List is
array (Natural range <>) of not null access Callback'Class;
function Is_Created (Self : Promise'Class) return Boolean
is (not Self.Is_Null);
end Promises;
------------
-- Chains --
------------
generic
with package Input_Promises is new Promises (<>);
with package Output_Promises is new Promises (<>);
package Chains is
type Callback is abstract new Input_Promises.Callback
with private;
procedure On_Next
(Self : in out Callback;
Input : Input_Promises.Result_Type;
Output : in out Output_Promises.Promise)
is abstract
with
Post'Class =>
Output.Get_State = Resolved
or Output.Get_State = Failed;
-- This is the procedure that needs overriding, not the one inherited
-- from Input_Promises. When chaining, a callback returns another
-- promise, to which the user can attach further callbacks, and so on.
--
-- Failures in a promise are by default propagated to the output
-- promise, unless you override the Failed primitive operation of
-- Self.
type Callback_List (<>) is private;
function Is_Registered
(Self : not null access Callback'Class) return Boolean
with Inline;
function Is_Registered (Self : Callback_List) return Boolean
with Inline;
-- Whether the callback has already been set on a promise. It is
-- invalid to use the same callback on multiple promises (or even
-- multiple times on the same promise).
function "and"
(Input : Input_Promises.Promise;
Cb : not null access Callback'Class)
return Output_Promises.Promise
with
Pre => not Is_Registered (Cb) and Input.Is_Created,
Post => Is_Registered (Cb)
and "and"'Result.Is_Created;
-- Chains two properties.
-- When Input is resolved, Cb is executed and will in turn resolve
-- the output promise
-- These functions return immediately a promise that will be resolved
-- later.
function "&"
(Cb : not null access Callback'Class;
Cb2 : not null access Input_Promises.Callback'Class)
return Callback_List
with
Pre => not Is_Registered (Cb);
-- ??? Results in GNAT bug box
-- Post => "and"'Result = Cb
-- and not Is_Registered ("and"'Result);
function "&"
(List : Callback_List;
Cb2 : not null access Input_Promises.Callback'Class)
return Callback_List;
-- Used to set multiple callbacks on the same promise, as in:
-- P & (new A and new B) & new C
-- Only Cb is expected to output a promise, which will be
-- forwarded to the next step (C in this example). Cb2 only
-- gets notified via its On_Next and On_Error primitives.
function "and"
(Input : Input_Promises.Promise;
Cb : Callback_List)
return Output_Promises.Promise
with
Pre => not Is_Registered (Cb) and Input.Is_Created,
Post => Is_Registered (Cb)
and "and"'Result.Is_Created;
-- Chaining multiple callbacks on the same promise
private
type Callback is abstract new Input_Promises.Callback with record
Promise : aliased Output_Promises.Promise;
end record;
overriding procedure On_Next
(Self : in out Callback; P : Input_Promises.Result_Type);
overriding procedure On_Error (Self : in out Callback; Reason : String);
type Callback_Array is array (Natural range <>)
of not null access Input_Promises.Callback'Class;
type Callback_List (N : Natural) is record
Cb : not null access Callback'Class;
Cb2 : Callback_Array (1 .. N);
end record;
end Chains;
end GNATCOLL.Promises;