Handle errors for Sakura directive + make them qualified

Author: EduardoLR10

lib/Ast.ml

@@ -66,10 +66,20 @@ module Expr = struct
         Logger.simply_error "Trying to extract a variable wrongly";
         exit 1
 
+  let extract_qualified_func_label :
+      func -> string Location.with_location * string Location.with_location =
+    function
+    | { name = [], name; _ } ->
+        Logger.error name.loc "Expected functor to have an unqualified label";
+        exit 1
+    | { name = [ qualifier ], name; _ } -> (qualifier, name)
+    | { name = qualifier :: _, _; _ } ->
+        Logger.error qualifier.loc "Expected functor to have a single qualifier";
+        exit 1
+
   let extract_func_label : func -> string = function
     | { name = [], name; _ } -> name.content
     | { name = first_segment :: _, _; _ } ->
-        Logger.simply_error first_segment.content;
         Logger.error first_segment.loc
           "Expected functor to have an unqualified label";
         exit 1

lib/database/Directive.ml

@@ -1,5 +1,28 @@
 open Compiler.Types
 
+module Error = struct
+  module Set = BatSet.String
+
+  let supported_directives =
+    Set.of_list [ "persisted"; "ephemeral"; "constraint"; "stored" ]
+
+  let treat_error_cases
+      ((qualifier, name) :
+        string Location.with_location * string Location.with_location)
+      (arity : int) : unit =
+    if arity <> 0 then (
+      Logger.error qualifier.loc "Sakura directives should be qualified atoms";
+      exit 1)
+    else if qualifier.content = "sakura" then (
+      if Set.mem name.content supported_directives then ()
+      else Logger.error name.loc @@ "Undefined Sakura directive:" ^ name.content;
+      exit 1)
+    else (
+      Logger.error qualifier.loc
+        "Sakura directives should be qualified with 'sakura'";
+      exit 1)
+end
+
 let compile (directive_loc : Location.location)
     ({ arity; _ } as func : Ast.Expr.func) (body : Ast.Clause.t list list)
     (step : Ast.Clause.t list * t -> t)
@@ -17,22 +40,29 @@ let compile (directive_loc : Location.location)
   | "project", 0, _ ->
       Logger.error directive_loc "Sakura does not support project directive";
       exit 1
-  | "persisted", _, _ ->
-      Logger.error directive_loc
-        "TODO: persisted directive is not yet implemented";
-      exit 1
-  | "ephemeral", _, _ ->
-      Logger.error directive_loc
-        "TODO: ephemeral directive is not yet implemented";
-      exit 1
-  | "constraint", _, _ ->
-      Logger.error directive_loc
-        "TODO: constraint directive is not yet implemented";
-      exit 1
-  | "stored", _, _ ->
-      Logger.unreachable directive_loc
-        "Stored procedures are not supported in Sakura yet";
-      exit 1
-  | _ ->
-      Logger.simply_unreachable "Unknown directive for Sakura";
-      exit 1
+  | _ -> (
+      let open Location in
+      let ((qualifier, name) as func_label) =
+        Ast.Expr.extract_qualified_func_label func
+      in
+      match (qualifier.content, name.content, arity) with
+      | "sakura", "persisted", 0 ->
+          Logger.error directive_loc
+            "TODO: persisted directive is not yet implemented";
+          exit 1
+      | "sakura", "ephemeral", 0 ->
+          Logger.error directive_loc
+            "TODO: ephemeral directive is not yet implemented";
+          exit 1
+      | "sakura", "constraint", 0 ->
+          Logger.error directive_loc
+            "TODO: constraint directive is not yet implemented";
+          exit 1
+      | "sakura", "stored", 0 ->
+          Logger.unreachable directive_loc
+            "Stored procedures are not supported in Sakura yet";
+          exit 1
+      | _ ->
+          Error.treat_error_cases func_label arity;
+          Logger.simply_unreachable "Unknown directive for Sakura";
+          exit 1)