Set up testing framework

semantics/lib/dune

@@ -1,3 +1,2 @@
 (library
- (name semanticsImpl)
- (modules_without_implementation packet queue))
+ (name rioSemantics))

semantics/lib/packet.ml

@@ -0,0 +1,20 @@
+module type Packet = sig
+  type t
+  type ord
+
+  val compare : ord -> ord -> int
+  val rank : t -> ord
+  val time : t -> ord
+  val weight : t -> ord
+end
+
+(* An implementation for packets (see MLI) *)
+module PacketImpl : Packet = struct
+  type t = float * float * float
+  type ord = float
+
+  let compare = compare
+  let rank (r, _, _) = r
+  let time (_, t, _) = t
+  let weight (_, _, w) = w
+end

semantics/lib/queue.ml

@@ -0,0 +1,44 @@
+open Packet
+
+module type Queue = sig
+  type elt
+  type t
+
+  val empty : t
+  val push : elt * t -> t
+  val pop : t -> elt option * t
+  val remove : elt option -> t -> t
+  val update : t -> t -> t list -> t list
+  val flush : t -> elt list
+end
+
+(* An implementation for queues (see MLI) *)
+module QueueImpl (Pkt : Packet) : Queue with type elt = Pkt.t = struct
+  type elt = Pkt.t
+  type t = elt list
+
+  let empty = []
+
+  let rec push (elem, lst) =
+    match lst with
+    | [] -> [ elem ]
+    | h :: t ->
+        if Pkt.rank h >= Pkt.rank elem then elem :: h :: t
+        else h :: push (elem, t)
+
+  let pop = function [] -> (None, []) | h :: t -> (Some h, t)
+
+  let rec update q_old q_new = function
+    | [] -> []
+    | h :: t -> if h = q_old then q_new :: t else q_old :: update q_old q_new t
+
+  let rec remove elem q =
+    match elem with
+    | None -> q
+    | Some e -> (
+        match q with
+        | [] -> []
+        | h :: t -> if h = e then t else h :: remove elem t)
+
+  let flush q = q
+end

semantics/lib/semantics.ml

@@ -9,7 +9,7 @@ module type SemanticsSig = sig
   type prog
   type pkt
   type queue
-  type state
+  type state = prog * queue list
 
   exception EvaluationError
 

semantics/test/dune

@@ -1,3 +1,3 @@
 (tests
  (names test_semantics)
- (libraries semanticsImpl ounit2))
+ (libraries rioSemantics ounit2))

semantics/test/test_semantics.ml

@@ -1,49 +1,81 @@
-open SemanticsImpl.Packet
-open SemanticsImpl.Queue
-open SemanticsImpl.Semantics
-open SemanticsImpl.Program
+open RioSemantics
 open OUnit2
 
-module PacketImpl : Packet = struct
-  type t = float * float * float
-  type ord = float
+module SemanticsTester
+    (Pkt : RioSemantics.Packet.Packet)
+    (Q : RioSemantics.Queue.Queue with type elt = Pkt.t) =
+struct
+  include RioSemantics.Program.Program
+  module S = RioSemantics.Semantics.Semantics (Pkt) (Q)
 
-  let compare = compare
-  let rank (r, _, _) = r
-  let time (_, t, _) = t
-  let weight (_, _, w) = w
-end
-
-module QueueImpl (Pkt : Packet) : Queue with type elt = Pkt.t = struct
-  type elt = Pkt.t
-  type t = elt list
-
-  let empty = []
-
-  let rec push (elem, lst) =
-    match lst with
-    | [] -> [ elem ]
-    | h :: t ->
-        if Pkt.rank h >= Pkt.rank elem then elem :: h :: t
-        else h :: push (elem, t)
-
-  let pop = function [] -> (None, []) | h :: t -> (Some h, t)
-
-  let rec update q_old q_new = function
+  (* Generate a list of packets by pushing and popping a given state tuple *)
+  let rec simulate state = function
     | [] -> []
-    | h :: t -> if h = q_old then q_new :: t else q_old :: update q_old q_new t
-
-  let rec remove elem q =
-    match elem with
-    | None -> q
-    | Some e -> (
-        match q with
-        | [] -> []
-        | h :: t -> if h = e then t else h :: remove elem t)
-
-  let flush q = q
-end
+    | (cmd, pkt, q) :: t ->
+        (* Command = true => push with packet and queue *)
+        if cmd then simulate (S.push (pkt, q, state)) t
+        else
+          (* Command = false => pop *)
+          let popped, new_state = S.pop state in
+          popped :: simulate new_state t
 
-module SemanticsTester (Pkt : Packet) (Q : Queue with type elt = Pkt.t) = struct
-  module S = Semantics (Pkt) (Q)
+  let programs =
+    [
+      (* 1. Simple FIFO with a Single Class *)
+      Fifo (Class "A");
+      (* 2. Union of Multiple Classes *)
+      Fifo (Union [ Class "A"; Class "B"; Class "C" ]);
+      (* 3. Earliest Deadline on a Union *)
+      EarliestDeadline (Union [ Class "X"; Class "Y" ]);
+      (* 4. Shortest Job Next with a Single Class *)
+      ShortestJobNext (Class "Z");
+      (* 5. Strict Combination of Two Streams *)
+      Strict
+        [ Fifo (Class "A"); ShortestJobNext (Union [ Class "B"; Class "C" ]) ];
+      (* 6. RoundRobin with Three Streams *)
+      RoundRobin
+        [
+          Fifo (Class "A");
+          EarliestDeadline (Class "B");
+          ShortestJobNext (Union [ Class "C"; Class "D" ]);
+        ];
+      (* 7. WeightedFair with Two Streams and Weights *)
+      WeightedFair ([ Fifo (Class "A"); EarliestDeadline (Class "B") ], [ 3; 5 ]);
+      (* 8. Complex Strict with a Nested RoundRobin *)
+      Strict
+        [
+          RoundRobin
+            [
+              Fifo (Class "A"); ShortestJobNext (Union [ Class "B"; Class "C" ]);
+            ];
+          EarliestDeadline (Class "D");
+        ];
+      (* 9. WeightedFair with Nested Streams *)
+      WeightedFair
+        ( [
+            Strict [ Fifo (Class "A"); EarliestDeadline (Class "B") ];
+            ShortestJobNext (Union [ Class "C"; Class "D" ]);
+          ],
+          [ 1; 2 ] );
+      (* 10. Deeply Nested Stream with Multiple Layers *)
+      RoundRobin
+        [
+          Strict
+            [
+              EarliestDeadline (Union [ Class "X"; Class "Y" ]);
+              RoundRobin
+                [
+                  ShortestJobNext (Class "Z");
+                  WeightedFair
+                    ( [
+                        Fifo (Class "A");
+                        Strict
+                          [ EarliestDeadline (Class "B"); Fifo (Class "C") ];
+                      ],
+                      [ 4; 2 ] );
+                ];
+            ];
+          Fifo (Union [ Class "D"; Class "E" ]);
+        ];
+    ]
 end